pax_global_header00006660000000000000000000000064127036567400014524gustar00rootroot0000000000000052 comment=b4c397076b8a8c0e908f1462a17d49c79a9d4772 roslisp-1.9.20/000077500000000000000000000000001270365674000133105ustar00rootroot00000000000000roslisp-1.9.20/.svnignore000066400000000000000000000000571270365674000153250ustar00rootroot00000000000000*.fasl *~ .build_version bin build lib src msg roslisp-1.9.20/CHANGELOG.rst000066400000000000000000000122401270365674000153300ustar00rootroot00000000000000^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Changelog for package roslisp ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1.9.20 (2016-04-14) ------------------- * Merge pull request `#28 `_ from gaya-/master In ADD_LISP_EXECUTABLE added a check for slashes in first argument * in cmake script minor nicification * [cmake] in ADD_LISP_EXECUTABLE added a check for slashes in first argument * Contributors: Gayane Kazhoyan, Georg Bartels 1.9.19 (2015-08-14) ----------- * Merge pull request `#25 `_ from airballking/symbol-codes roslisp-msg-protocol: looking up symbols from constants * Followed Gaya's suggestion of throwing an error if no symbol-code with the requested code can be found in (code-symbol ...). * Merge pull request `#26 `_ from gaya-/deprecated-quit Replaced deprecated SB-EXT:QUIT with SB-EXT:EXIT * Merge pull request `#19 `_ from gaya-/master Fixed the outdated executables generation pipeline * Replaced deprecated SB-EXT:QUIT with SB-EXT:EXIT * Contributors: Dirk Thomas, Gayane Kazhoyan, Georg Bartels 1.9.17 (2014-10-02) ------------------- * Merge pull request `#20 `_ from daewok/use_sim_time use_sim_time parameter should be absolute. * Merge pull request `#18 `_ from airballking/fix-issue17 fix for ASDF3 compatibility * Merge pull request `#16 `_ from jannikb/master Fixed Issue `ros/roslisp#12 `_ * Merge pull request `#15 `_ from jannikb/master Start fixing issue `ros/roslisp#12 `_ * Contributors: Eric Timmons, Georg Bartels, Jannik Buckelo, Lorenz Mösenlechner 1.9.16 (2014-04-22) ------------------- * Added Georg Bartels as maintainer in package.xml. * Bug-fix: Export SERVICE-CALL-ERROR symbol. * Bug-fix: Don't throw END-OF-FILE condition in TCPROS-DO-SERVICE-REQUEST. * Bug-fix: Corrected typo 'close-persistent-service'. * Contributors: Gayane Kazhoyan, Georg Bartels 1.9.15 (2013-12-03) ------------------- * Bug-fix: Make sure 'asdf-paths-to-add' does not contain any 'nil' pathnames. * Contributors: Georg Bartels 1.9.14 (2013-11-21) ------------------- * Merge pull request (`#10 `_) from ros/relocatable resolve roslisp path in installspace at runtime (`#490 `_) * resolve roslisp path in installspace at runtime (`#490 `_) * Contributors: Dirk Thomas, Georg Bartels, Lorenz Moesenlechner 1.9.13 (2013-06-24) ------------------- * Merge pull request (`#9 `_) from ros/fix_env_hook fix environment hook to set ROSLISP_PACKAGE_DIRECTORIES in devel space * fix environment hook to set ROSLISP_PACKAGE_DIRECTORIES to all devel spaces * Contributors: Dirk Thomas, Georg Bartels 1.9.12 (2013-06-18) ------------------- * Merge pull request (`#3 `_) from airballking/master Convenience function create messages for publication object AND convenience service-client interface. * added buildtool_depend catkin to package.xml * Added a convenience function to create message for topics that uses publication to get the message type. * Contributors: Aaron Blasdel, Georg Bartels, Lorenz Moesenlechner 1.9.11 (2012-11-28) ------------------- * Improved wrapper script generation to not require the ROS package sbcl. * Throw an error if *LOAD-TRUENAME* is unbound in roslisp-sbcl-init. * Contributors: Lorenz Moesenlechner 1.9.10 (2012-11-20) ------------------- * Removed directory `asdf` form install target. * Don't use rospack or the asdf subdirectory to find system load-manifest. Instead, we use the directory of the initfile directly, assuming that it's always in the roslisp directory. * Got rid of asdf subdirectory and symbolic links. As of asdf2, the symbolic links to asd files are not required anymore. They even screw up the deb build proces. Deleting them. * Contributors: Lorenz Moesenlechner 1.9.9 (2012-11-09) ------------------ * Added find_package for catkin in CMakeLists.txt. * Contributors: Lorenz Moesenlechner 1.9.8 (2012-10-26) ------------------ * Check for unambiguous type declaration in with-fields macro. If the user declares the type using OR, we cannot use it for optimizing the macro expansion since it is ambiguous. Fixes (`#1 `_). * Updated dependencies in manifest.xml file. * Updated run-dependencies in package.xml. * Updated CMakeLists for new catkin. * Got rid of call of catkin_stack. * Contributors: Lorenz Moesenlechner 1.9.7 (2012-09-27) ------------------ * Change of maintainer to Lorenz Moesenlechner * Various catkin fixes * Contributors: Dave Hershberger, Dirk Thomas, Lorenz Moesenlechner 1.9.0 (2012-08-30) ------------------ * Begin Catkinization * Initial development * Contributors: Dirk Thomas, Lorenz Moesenlechner, Thibault Kruse, bhaskara, dirk-thomas, gerkey, kruset, kwc, lorenz, mkjaergaard, tfoote roslisp-1.9.20/CMakeLists.txt000066400000000000000000000016641270365674000160570ustar00rootroot00000000000000cmake_minimum_required(VERSION 2.8.3) project(roslisp) find_package(catkin REQUIRED) catkin_package(CFG_EXTRAS roslisp-extras.cmake) add_subdirectory(env-hooks) foreach(dir load-manifest rosbuild roslisp-msg-protocol src s-xml s-xml-rpc utils) install(DIRECTORY ${dir} DESTINATION share/${PROJECT_NAME} PATTERN ".svn" EXCLUDE PATTERN "genmsg_lisp.py" EXCLUDE) endforeach() # install legacy infrastructure needed by rosbuild install(FILES manifest.xml DESTINATION ${CATKIN_PACKAGE_SHARE_DESTINATION}) install(DIRECTORY scripts DESTINATION ${CATKIN_PACKAGE_SHARE_DESTINATION} USE_SOURCE_PERMISSIONS PATTERN ".svn" EXCLUDE PATTERN "genmsg_lisp.py" EXCLUDE) install(FILES rosbuild/roslisp.cmake DESTINATION ${CATKIN_PACKAGE_SHARE_DESTINATION}/rosbuild) install(PROGRAMS rosbuild/scripts/genmsg_lisp.py DESTINATION ${CATKIN_PACKAGE_SHARE_DESTINATION}/rosbuild/scripts) roslisp-1.9.20/README.rst000066400000000000000000000002221270365674000147730ustar00rootroot00000000000000roslisp ======== Common Lisp library for interaction with ROS (Robot operating system). See http://www.ros.org/wiki/roslisp Tested using SBCL. roslisp-1.9.20/cmake/000077500000000000000000000000001270365674000143705ustar00rootroot00000000000000roslisp-1.9.20/cmake/roslisp-extras.cmake.em000066400000000000000000000075321270365674000210000ustar00rootroot00000000000000# # Generated from roslisp/cmake/roslisp-extras.cmake.in # @[if DEVELSPACE]@ # location of script in develspace set(ROSLISP_MAKE_NODE_BIN "@(CMAKE_CURRENT_SOURCE_DIR)/scripts/make_node_exec") set(ROSLISP_COMPILE_MANIFEST_BIN "@(CMAKE_CURRENT_SOURCE_DIR)/scripts/compile_load_manifest") set(ROSLISP_EXE_SCRIPT "@(CMAKE_CURRENT_SOURCE_DIR)/scripts/make_exe_script") @[else]@ # location of script in installspace set(ROSLISP_MAKE_NODE_BIN "${roslisp_DIR}/../scripts/make_node_exec") set(ROSLISP_COMPILE_MANIFEST_BIN "${roslisp_DIR}/../scripts/compile_load_manifest") set(ROSLISP_EXE_SCRIPT "${roslisp_DIR}/../scripts/make_exe_script") @[end if]@ # Build up a list of executables, in order to make them depend on each # other, to avoid building them in parallel, because it's not safe to do # that. # The first entry in this list will be a target to compile ros-load-manifest # as all the executables depend on it. if(NOT TARGET _roslisp_load_manifest) add_custom_target(_roslisp_load_manifest ALL COMMAND ${ROSLISP_COMPILE_MANIFEST_BIN}) endif() set(ROSLISP_EXECUTABLES _roslisp_load_manifest) # example usage: # add_compiled_lisp_executable(my_script my-system my-system:my-func [my_targetname]) function(add_compiled_lisp_executable output system_name entry_point) if(${ARGC} LESS 3 OR ${ARGC} GREATER 4) message(SEND_ERROR "[roslisp] add_compiled_lisp_executable can only have 3 or 4 arguments") elseif(${ARGC} LESS 4) set(targetname _roslisp_${output}) else() set(extra_macro_args ${ARGN}) list(GET extra_macro_args 0 targetname) endif() string(REPLACE "/" "_" targetname ${targetname}) set(targetdir ${CATKIN_DEVEL_PREFIX}/${CATKIN_PACKAGE_BIN_DESTINATION}) # Add dummy custom command to get make clean behavior right. add_custom_command(OUTPUT ${targetdir}/${output} ${targetdir}/${output}.lisp COMMAND echo -n) add_custom_target(${targetname} ALL DEPENDS ${targetdir}/${output} ${targetdir}/${output}.lisp COMMAND ${ROSLISP_MAKE_NODE_BIN} ${PROJECT_NAME} ${system_name} ${entry_point} ${targetdir}/${output}) # Make this executable depend on all previously declared executables, to serialize them. if(ROSLISP_EXECUTABLES) add_dependencies(${targetname} ${ROSLISP_EXECUTABLES}) endif() # Add this executable to the list of executables on which all future # executables will depend. list(APPEND ROSLISP_EXECUTABLES ${targetname}) set(ROSLISP_EXECUTABLES "${ROSLISP_EXECUTABLES}" PARENT_SCOPE) # mark the generated executables for installation install(PROGRAMS ${targetdir}/${output} DESTINATION ${CATKIN_PACKAGE_BIN_DESTINATION}) install(FILES ${targetdir}/${output}.lisp DESTINATION ${CATKIN_PACKAGE_BIN_DESTINATION}) endfunction(add_compiled_lisp_executable) # example usage: # add_lisp_executable(my_script my-system my-package:my-func) function(add_lisp_executable output system_name entry_point) if(NOT ${ARGC} EQUAL 3) message(SEND_ERROR "[roslisp] add_lisp_executable can only have 3 arguments") endif() if(output MATCHES "/") message(WARNING "First argument of ADD_LISP_EXECUTABLE (${output}) cannot contain slashes! Ignoring.") string(REPLACE "/" "_" output ${output}) endif() set(targetdir ${CATKIN_DEVEL_PREFIX}/${CATKIN_PACKAGE_BIN_DESTINATION}) set(targetname _roslisp_${output}) # create directory if it does not exist file(MAKE_DIRECTORY ${targetdir}) # generate script add_custom_command(OUTPUT ${targetdir}/${output} COMMAND ${ROSLISP_EXE_SCRIPT} ${PROJECT_NAME} ${system_name} ${entry_point} ${targetdir}/${output} DEPENDS ${ROSLISP_EXE_SCRIPT} COMMENT "Generating lisp exe script ${targetdir}/${output}" VERBATIM) add_custom_target(${targetname} ALL DEPENDS ${targetdir}/${output}) # mark the generated executables for installation install(PROGRAMS ${targetdir}/${output} DESTINATION ${CATKIN_PACKAGE_BIN_DESTINATION}) endfunction(add_lisp_executable) roslisp-1.9.20/env-hooks/000077500000000000000000000000001270365674000152215ustar00rootroot00000000000000roslisp-1.9.20/env-hooks/99.roslisp.sh000066400000000000000000000015771270365674000175220ustar00rootroot00000000000000# generated from roslisp/env-hooks/99.roslisp.sh.in # python function to generate ROSLISP package directories containing all devel spaces based on all workspaces PYTHON_CODE_BUILD_ROSLISP_PACKAGE_DIRECTORIES=$(cat < (length *current-ros-package*) 0)) (let ((paths (asdf-paths-to-add *current-ros-package*))) (when debug-print (format t "~&Current ros package is ~a. Searching for asdf system ~a in directories:~& ~a" *current-ros-package* def paths)) (dolist (p paths) (let ((filename (merge-pathnames (make-pathname :name def :type "asd") p))) (when (probe-file filename) (when debug-print (format t "~& Found ~a" filename)) (return-from asdf-ros-search filename)))) (when debug-print (format t "~& Not found"))) (when debug-print (format t "~&asdf-ros-search not invoked since *current-ros-package* is ~a" *current-ros-package*)))) (asdf:initialize-source-registry (let ((roslisp-package-directories (sb-posix:getenv "ROSLISP_PACKAGE_DIRECTORIES")) (ros-package-path (sb-posix:getenv "ROS_PACKAGE_PATH")) ;; during the transition from asdf2 to asdf3 the utility function ;; 'split-string' moved from package 'asdf' to package 'uiop'. ;; Hence, the version-dependent function-call (split-string-symbol (if (asdf:version-satisfies (asdf:asdf-version) "3.0") (intern "SPLIT-STRING" :uiop) (intern "SPLIT-STRING" :asdf)))) `(:source-registry ,@(when roslisp-package-directories (mapcan (lambda (path) (when (and path (> (length path) 0)) `((:tree ,path)))) (funcall split-string-symbol roslisp-package-directories :separator '(#\:)))) ,@(when ros-package-path (mapcan (lambda (path) (when (and path (> (length path) 0)) `((:tree ,path)))) (funcall split-string-symbol ros-package-path :separator '(#\:)))) ;; NOTE(lorenz): this looks to me as sort of an ugly hack but we ;; should not break the user's source registry ;; configuration. Instead, we inherit the user's configuration if ;; it exists and just add our entries at the beginning. ,@(if (and (boundp 'asdf:*source-registry-parameter*) (eq (car asdf:*source-registry-parameter*) :source-registry)) (cdr asdf:*source-registry-parameter*) (list :inherit-configuration))))) (setq asdf:*system-definition-search-functions* (append asdf:*system-definition-search-functions* '(asdf-ros-search))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; top level ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun load-manifest (package) "Walks down the tree of dependencies of this ros package. Backtracks when it reaches a leaf or a package with no asdf/ subdirectory. Adds all the asdf directories it finds to the asdf:*central-registry*." (cerror "continue" "Load manifest deprecated!") (dolist (p (asdf-paths-to-add package)) (pushnew p asdf:*central-registry* :test #'equal))) (defun load-system (package &optional (asdf-name package) force) "Sets *CURRENT-ROS-PACKAGE* and performs an asdf load operation on `package'" (let ((*current-ros-package* package)) (asdf:operate 'asdf:load-op asdf-name :force force))) roslisp-1.9.20/load-manifest/ros-load-manifest.asd000066400000000000000000000002261270365674000220500ustar00rootroot00000000000000;;;; -*- Mode: LISP -*- (defsystem :ros-load-manifest :name "ros-load-manifest" :components ((:file "load-manifest")) :depends-on (:sb-posix)) roslisp-1.9.20/manifest.xml000066400000000000000000000011411270365674000156350ustar00rootroot00000000000000 This package is a Lisp client library for ROS, the Robot Operating System. Bhaskara Marthi, Brian Gerkey, Lorenz Mösenlechner, Thibault Kruse BSD http://ros.org/wiki/roslisp roslisp-1.9.20/package.xml000066400000000000000000000015321270365674000154260ustar00rootroot00000000000000 roslisp 1.9.20 Lisp client library for ROS, the Robot Operating System. Georg Bartels Lorenz Moesenlechner BSD Bhaskara Marthi Brian Gerkey Lorenz Moesenlechner Thibault Kruse http://ros.org/wiki/roslisp catkin roslang sbcl rospack rosgraph_msgs std_srvs roslisp-1.9.20/rosbuild/000077500000000000000000000000001270365674000151335ustar00rootroot00000000000000roslisp-1.9.20/rosbuild/roslisp.cmake000066400000000000000000000144541270365674000176400ustar00rootroot00000000000000rosbuild_find_ros_package(roslisp) # Message-generation support. macro(genmsg_lisp) rosbuild_get_msgs(_msglist) set(_autogen "") foreach(_msg ${_msglist}) # Construct the path to the .msg file set(_input ${PROJECT_SOURCE_DIR}/msg/${_msg}) rosbuild_gendeps(${PROJECT_NAME} ${_msg}) set(genmsg_lisp_exe ${roslisp_PACKAGE_PATH}/rosbuild/scripts/genmsg_lisp.py) set(_output_lisp ${PROJECT_SOURCE_DIR}/msg_gen/lisp/${_msg}) set(_output_lisp_package ${PROJECT_SOURCE_DIR}/msg_gen/lisp/_package.lisp) set(_output_lisp_export ${PROJECT_SOURCE_DIR}/msg_gen/lisp/_package_${_msg}) string(REPLACE ".msg" ".lisp" _output_lisp ${_output_lisp}) string(REPLACE ".msg" ".lisp" _output_lisp_export ${_output_lisp_export}) # Add the rule to build the .h and .py from the .msg add_custom_command(OUTPUT ${_output_lisp} ${_output_lisp_package} ${_output_lisp_export} COMMAND ${genmsg_lisp_exe} ${_input} DEPENDS ${_input} ${genmsg_lisp_exe} ${gendeps_exe} ${${PROJECT_NAME}_${_msg}_GENDEPS} ${ROS_MANIFEST_LIST}) list(APPEND _autogen ${_output_lisp} ${_output_lisp_package} ${_output_lisp_export}) endforeach(_msg) # Create a target that depends on the union of all the autogenerated # files add_custom_target(ROSBUILD_genmsg_lisp DEPENDS ${_autogen}) # Make our target depend on rosbuild_premsgsrvgen, to allow any # pre-msg/srv generation steps to be done first. add_dependencies(ROSBUILD_genmsg_lisp rosbuild_premsgsrvgen) # Add our target to the top-level genmsg target, which will be fired if # the user calls genmsg() add_dependencies(rospack_genmsg ROSBUILD_genmsg_lisp) if(_autogen) # Also set up to clean the msg_gen directory get_directory_property(_old_clean_files ADDITIONAL_MAKE_CLEAN_FILES) list(APPEND _old_clean_files ${PROJECT_SOURCE_DIR}/msg_gen) set_directory_properties(PROPERTIES ADDITIONAL_MAKE_CLEAN_FILES "${_old_clean_files}") endif(_autogen) endmacro(genmsg_lisp) # Call the macro we just defined. genmsg_lisp() # Service-generation support. macro(gensrv_lisp) rosbuild_get_srvs(_srvlist) set(_autogen "") foreach(_srv ${_srvlist}) # Construct the path to the .srv file set(_input ${PROJECT_SOURCE_DIR}/srv/${_srv}) rosbuild_gendeps(${PROJECT_NAME} ${_srv}) set(gensrv_lisp_exe ${roslisp_PACKAGE_PATH}/rosbuild/scripts/genmsg_lisp.py) set(_output_lisp ${PROJECT_SOURCE_DIR}/srv_gen/lisp/${_srv}) set(_output_lisp_package ${PROJECT_SOURCE_DIR}/srv_gen/lisp/_package.lisp) set(_output_lisp_export ${PROJECT_SOURCE_DIR}/srv_gen/lisp/_package_${_srv}) string(REPLACE ".srv" ".lisp" _output_lisp ${_output_lisp}) string(REPLACE ".srv" ".lisp" _output_lisp_export ${_output_lisp_export}) # Add the rule to build the .h and .py from the .srv add_custom_command(OUTPUT ${_output_lisp} ${_output_lisp_package} ${_output_lisp_export} COMMAND ${gensrv_lisp_exe} ${_input} DEPENDS ${_input} ${gensrv_lisp_exe} ${gendeps_exe} ${${PROJECT_NAME}_${_srv}_GENDEPS} ${ROS_MANIFEST_LIST}) list(APPEND _autogen ${_output_lisp} ${_output_lisp_package} ${_output_lisp_export}) endforeach(_srv) # Create a target that depends on the union of all the autogenerated # files add_custom_target(ROSBUILD_gensrv_lisp DEPENDS ${_autogen}) # Make our target depend on rosbuild_premsgsrvgen, to allow any # pre-msg/srv generation steps to be done first. add_dependencies(ROSBUILD_gensrv_lisp rosbuild_premsgsrvgen) # Add our target to the top-level gensrv target, which will be fired if # the user calls gensrv() add_dependencies(rospack_gensrv ROSBUILD_gensrv_lisp) if(_autogen) # Also set up to clean the srv_gen directory get_directory_property(_old_clean_files ADDITIONAL_MAKE_CLEAN_FILES) list(APPEND _old_clean_files ${PROJECT_SOURCE_DIR}/srv_gen) set_directory_properties(PROPERTIES ADDITIONAL_MAKE_CLEAN_FILES "${_old_clean_files}") endif(_autogen) endmacro(gensrv_lisp) # Call the macro we just defined. gensrv_lisp() # Old rospack_add_lisp_executable. #macro(rospack_add_lisp_executable exe lispfile) # add_custom_command(OUTPUT ${CMAKE_CURRENT_SOURCE_DIR}/${exe} # COMMAND ${roslisp_make_node_exe} ${CMAKE_CURRENT_SOURCE_DIR}/${lispfile} ${roslisp_image_file} ${CMAKE_CURRENT_SOURCE_DIR}/${exe} # DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${lispfile} ${roslisp_image_file}) # set(_targetname _roslisp_${exe}) # string(REPLACE "/" "_" _targetname ${_targetname}) # add_custom_target(${_targetname} ALL # DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${exe}) # add_dependencies(${_targetname} _rospack_genmsg) # add_dependencies(${_targetname} _rospack_gensrv) #endmacro(rospack_add_lisp_executable) # New rospack_add_lisp_executable (#1102) rosbuild_find_ros_package(roslisp) set(roslisp_make_node_exe ${roslisp_PACKAGE_PATH}/scripts/make_node_exec) # Build up a list of executables, in order to make them depend on each # other, to avoid building them in parallel, because it's not safe to do # that. set(roslisp_executables) macro(rosbuild_add_lisp_executable _output _system_name _entry_point) set(_targetname _roslisp_${_output}) string(REPLACE "/" "_" _targetname ${_targetname}) # Add dummy custom command to get make clean behavior right. add_custom_command(OUTPUT ${CMAKE_CURRENT_SOURCE_DIR}/${_output} ${CMAKE_CURRENT_SOURCE_DIR}/${_output}.lisp COMMAND echo -n) add_custom_target(${_targetname} ALL DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${_output} ${CMAKE_CURRENT_SOURCE_DIR}/${_output}.lisp COMMAND ${roslisp_make_node_exe} ${PROJECT_NAME} ${_system_name} ${_entry_point} ${CMAKE_CURRENT_SOURCE_DIR}/${_output}) # Make this executable depend on all previously declared executables, to # serialize them. add_dependencies(${_targetname} rosbuild_precompile ${roslisp_executables}) # Add this executable to the list of executables on which all future # executables will depend. list(APPEND roslisp_executables ${_targetname}) endmacro(rosbuild_add_lisp_executable) macro(rospack_add_lisp_executable _output _system_name _entry_point) _rosbuild_warn_deprecate_rospack_prefix(rospack_add_lisp_executable) rosbuild_add_lisp_executable(${_output} ${_system_name} ${_entry_point}) endmacro(rospack_add_lisp_executable) roslisp-1.9.20/rosbuild/scripts/000077500000000000000000000000001270365674000166225ustar00rootroot00000000000000roslisp-1.9.20/rosbuild/scripts/genmsg_lisp.py000077500000000000000000000733051270365674000215160ustar00rootroot00000000000000#!/usr/bin/env python # Software License Agreement (BSD License) # # Copyright (c) 2009, Willow Garage, Inc. # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * Redistributions in binary form must reproduce the above # copyright notice, this list of conditions and the following # disclaimer in the documentation and/or other materials provided # with the distribution. # * Neither the name of Willow Garage, Inc. nor the names of its # contributors may be used to endorse or promote products derived # from this software without specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS # FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE # COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, # BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN # ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. # ## ROS message source code generation for Lisp ## ## Converts ROS .msg and .srv files in a package into Lisp source code ## t0: needed for script to work ## t1: for reference; remove once running ## t2: can be changed once we remove strict diff-compatibility requirement with old version of genmsg_lisp import sys import os import traceback import re import roslib.msgs import roslib.srvs import roslib.packages import roslib.gentools from roslib.msgs import MsgSpec from roslib.srvs import SrvSpec try: from cStringIO import StringIO #Python 2.x except ImportError: from io import StringIO #Python 3.x ############################################################ # Built in types ############################################################ def is_fixnum(t): return t in ['int8', 'uint8', 'int16', 'uint16'] def is_integer(t): return is_fixnum(t) or t in ['byte', 'char', 'int32', 'uint32', 'int64', 'uint64'] #t2 byte, char can be fixnum def is_signed_int(t): return t in ['int8', 'int16', 'int32', 'int64'] def is_unsigned_int(t): return t in ['uint8', 'uint16', 'uint32', 'uint64'] def is_bool(t): return t == 'bool' def is_string(t): return t == 'string' def is_float(t): return t in ['float16', 'float32', 'float64'] def is_time(t): return t in ['time', 'duration'] def field_type(f): if f.is_builtin: elt_type = lisp_type(f.base_type) else: elt_type = msg_type(f) if f.is_array: return '(cl:vector %s)'%elt_type else: return elt_type def parse_msg_type(f): if f.base_type == 'Header': return ('std_msgs', 'Header') else: return f.base_type.split('/') # t2 no need for is_array def msg_type(f): (pkg, msg) = parse_msg_type(f) return '%s-msg:%s'%(pkg, msg) def lisp_type(t): if is_fixnum(t): return 'cl:fixnum' elif is_integer(t): return 'cl:integer' elif is_bool(t): return 'cl:boolean' elif is_float(t): return 'cl:float' elif is_time(t): return 'cl:real' elif is_string(t): return 'cl:string' else: raise ValueError('%s is not a recognized primitive type'%t) def field_initform(f): if f.is_builtin: initform = lisp_initform(f.base_type) elt_type = lisp_type(f.base_type) else: initform = '(cl:make-instance \'%s)'%msg_type(f) elt_type = msg_type(f) if f.is_array: len = f.array_len or 0 return '(cl:make-array %s :element-type \'%s :initial-element %s)'%(len, elt_type, initform) else: return initform def lisp_initform(t): if is_integer(t): return '0' elif is_bool(t): return 'cl:nil' elif is_float(t): return '0.0' elif is_time(t): return 0 elif is_string(t): return '\"\"' else: raise ValueError('%s is not a recognized primitive type'%t) NUM_BYTES = {'int8': 1, 'int16': 2, 'int32': 4, 'int64': 8, 'uint8': 1, 'uint16': 2, 'uint32': 4, 'uint64': 8} ############################################################ # Indented writer ############################################################ class IndentedWriter(): def __init__(self, s): self.str = s self.indentation = 0 self.block_indent = False def write(self, s, indent=True, newline=True): if not indent: newline = False if self.block_indent: self.block_indent = False else: if newline: self.str.write('\n') if indent: for i in range(self.indentation): self.str.write(' ') self.str.write(s) def newline(self): self.str.write('\n') def inc_indent(self, inc=2): self.indentation += inc def dec_indent(self, dec=2): self.indentation -= dec def reset_indent(self): self.indentation = 0 def block_next_indent(self): self.block_indent = True class Indent(): def __init__(self, w, inc=2, indent_first=True): self.writer = w self.inc = inc self.indent_first = indent_first def __enter__(self): self.writer.inc_indent(self.inc) if not self.indent_first: self.writer.block_next_indent() def __exit__(self, type, val, traceback): self.writer.dec_indent(self.inc) def write_begin(s, spec, path, is_service=False): "Writes the beginning of the file: a comment saying it's auto-generated and the in-package form" s.write('; Auto-generated. Do not edit!\n\n\n', newline=False) suffix = 'srv' if is_service else 'msg' s.write('(cl:in-package %s-%s)\n\n\n'%(spec.package, suffix), newline=False) def write_html_include(s, spec, is_srv=False): s.write(';//! \\htmlinclude %s.msg.html\n'%spec.actual_name, newline=False) # t2 def write_slot_definition(s, field): "Write the definition of a slot corresponding to a single message field" s.write('(%s'%field.name) with Indent(s, 1): s.write(':reader %s'%field.name) s.write(':initarg :%s'%field.name) s.write(':type %s'%field_type(field)) i = 0 if field.is_array else 1 # t2 with Indent(s, i): s.write(':initform %s)'%field_initform(field)) def write_deprecated_readers(s, spec): suffix = 'srv' if spec.component_type == 'service' else 'msg' for field in spec.parsed_fields(): s.newline() s.write('(cl:ensure-generic-function \'%s-val :lambda-list \'(m))' % field.name) s.write('(cl:defmethod %s-val ((m %s))'%(field.name, message_class(spec))) with Indent(s): s.write('(roslisp-msg-protocol:msg-deprecation-warning "Using old-style slot reader %s-%s:%s-val is deprecated. Use %s-%s:%s instead.")'%(spec.package, suffix, field.name, spec.package, suffix, field.name)) s.write('(%s m))'%field.name) def write_defclass(s, spec): "Writes the defclass that defines the message type" cl = message_class(spec) new_cl = new_message_class(spec) suffix = 'srv' if spec.component_type == 'service' else 'msg' s.write('(cl:defclass %s (roslisp-msg-protocol:ros-message)'%cl) with Indent(s): s.write('(') with Indent(s, inc=1, indent_first=False): for field in spec.parsed_fields(): write_slot_definition(s, field) s.write(')', indent=False) s.write(')') s.newline() s.write('(cl:defclass %s (%s)'%(new_cl, cl)) with Indent(s): s.write('())') s.newline() s.write('(cl:defmethod cl:initialize-instance :after ((m %s) cl:&rest args)'%cl) with Indent(s): s.write('(cl:declare (cl:ignorable args))') s.write('(cl:unless (cl:typep m \'%s)'%new_cl) with Indent(s): s.write('(roslisp-msg-protocol:msg-deprecation-warning "using old message class name %s-%s:%s is deprecated: use %s-%s:%s instead.")))'%(spec.package, suffix, cl, spec.package, suffix, new_cl)) def message_class(spec): """ Return the CLOS class name for this message type """ return '<%s>'%spec.actual_name def new_message_class(spec): return spec.actual_name def write_serialize_length(s, v, is_array=False): #t2 var = '__ros_arr_len' if is_array else '__ros_str_len' s.write('(cl:let ((%s (cl:length %s)))'%(var, v)) with Indent(s): for x in range(0, 32, 8): s.write('(cl:write-byte (cl:ldb (cl:byte 8 %s) %s) ostream)'%(x, var)) s.write(')', indent=False) def write_serialize_bits(s, v, num_bytes): for x in range(0, num_bytes*8, 8): s.write('(cl:write-byte (cl:ldb (cl:byte 8 %s) %s) ostream)'%(x, v)) def write_serialize_bits_signed(s, v, num_bytes): num_bits = num_bytes*8 s.write('(cl:let* ((signed %s) (unsigned (cl:if (cl:< signed 0) (cl:+ signed %s) signed)))'%(v, 2**num_bits)) with Indent(s): write_serialize_bits(s, 'unsigned', num_bytes) s.write(')') # t2: can get rid of this lookup_slot stuff def write_serialize_builtin(s, f, var='msg', lookup_slot=True): v = '(cl:slot-value %s \'%s)'%(var, f.name) if lookup_slot else var if f.base_type == 'string': write_serialize_length(s, v) s.write('(cl:map cl:nil #\'(cl:lambda (c) (cl:write-byte (cl:char-code c) ostream)) %s)'%v) elif f.base_type == 'float32': s.write('(cl:let ((bits %s))'%'(roslisp-utils:encode-single-float-bits %s)'%v) with Indent(s): write_serialize_bits(s, 'bits', 4) s.write(')', False) elif f.base_type == 'float64': s.write('(cl:let ((bits %s))'%'(roslisp-utils:encode-double-float-bits %s)'%v) with Indent(s): write_serialize_bits(s, 'bits', 8) s.write(')', False) elif f.base_type == 'bool': s.write('(cl:write-byte (cl:ldb (cl:byte 8 0) (cl:if %s 1 0)) ostream)'%v) elif f.base_type in ['byte', 'char']: s.write('(cl:write-byte (cl:ldb (cl:byte 8 0) %s) ostream)'%v) elif f.base_type in ['duration', 'time']: s.write('(cl:let ((__sec (cl:floor %s))'%v) s.write(' (__nsec (cl:round (cl:* 1e9 (cl:- %s (cl:floor %s))))))'%(v,v)) with Indent(s): write_serialize_bits(s, '__sec', 4) write_serialize_bits(s, '__nsec', 4) s.write(')', False) elif is_signed_int(f.base_type): write_serialize_bits_signed(s, v, NUM_BYTES[f.base_type]) elif is_unsigned_int(f.base_type): write_serialize_bits(s, v, NUM_BYTES[f.base_type]) else: raise ValueError('Unknown type: %s', f.base_type) def write_serialize_field(s, f): slot = '(cl:slot-value msg \'%s)'%f.name if f.is_array: if not f.array_len: write_serialize_length(s, slot, True) s.write('(cl:map cl:nil #\'(cl:lambda (ele) ') var = 'ele' s.block_next_indent() lookup_slot = False else: var='msg' lookup_slot = True if f.is_builtin: write_serialize_builtin(s, f, var, lookup_slot=lookup_slot) else: to_write = slot if lookup_slot else var #t2 s.write('(roslisp-msg-protocol:serialize %s ostream)'%to_write) if f.is_array: s.write(')', False) s.write(' %s)'%slot) def write_serialize(s, spec): """ Write the serialize method """ s.write('(cl:defmethod roslisp-msg-protocol:serialize ((msg %s) ostream)'%message_class(spec)) with Indent(s): s.write('"Serializes a message object of type \'%s"'%message_class(spec)) for f in spec.parsed_fields(): write_serialize_field(s, f) s.write(')') # t2 can get rid of is_array def write_deserialize_length(s, is_array=False): var = '__ros_arr_len' if is_array else '__ros_str_len' s.write('(cl:let ((%s 0))'%var) with Indent(s): for x in range(0, 32, 8): s.write('(cl:setf (cl:ldb (cl:byte 8 %s) %s) (cl:read-byte istream))'%(x, var)) def write_deserialize_bits(s, v, num_bytes): for x in range(0, num_bytes*8, 8): s.write('(cl:setf (cl:ldb (cl:byte 8 %s) %s) (cl:read-byte istream))'%(x, v)) def write_deserialize_bits_signed(s, v, num_bytes): s.write('(cl:let ((unsigned 0))') num_bits = 8*num_bytes with Indent(s): write_deserialize_bits(s, 'unsigned', num_bytes) s.write('(cl:setf %s (cl:if (cl:< unsigned %s) unsigned (cl:- unsigned %s))))'%(v, 2**(num_bits-1), 2**num_bits)) def write_deserialize_builtin(s, f, v): if f.base_type == 'string': write_deserialize_length(s) with Indent(s): s.write('(cl:setf %s (cl:make-string __ros_str_len))'%v) s.write('(cl:dotimes (__ros_str_idx __ros_str_len msg)') with Indent(s): s.write('(cl:setf (cl:char %s __ros_str_idx) (cl:code-char (cl:read-byte istream)))))'%v) elif f.base_type == 'float32': s.write('(cl:let ((bits 0))') with Indent(s): write_deserialize_bits(s, 'bits', 4) s.write('(cl:setf %s (roslisp-utils:decode-single-float-bits bits)))'%v) elif f.base_type == 'float64': s.write('(cl:let ((bits 0))') with Indent(s): write_deserialize_bits(s, 'bits', 8) s.write('(cl:setf %s (roslisp-utils:decode-double-float-bits bits)))'%v) elif f.base_type == 'bool': s.write('(cl:setf %s (cl:not (cl:zerop (cl:read-byte istream))))'%v) elif f.base_type in ['byte', 'char']: s.write('(cl:setf (cl:ldb (cl:byte 8 0) %s) (cl:read-byte istream))'%v) elif f.base_type in ['duration', 'time']: s.write('(cl:let ((__sec 0) (__nsec 0))') with Indent(s): write_deserialize_bits(s, '__sec', 4) write_deserialize_bits(s, '__nsec', 4) s.write('(cl:setf %s (cl:+ (cl:coerce __sec \'cl:double-float) (cl:/ __nsec 1e9))))'%v) elif is_signed_int(f.base_type): write_deserialize_bits_signed(s, v, NUM_BYTES[f.base_type]) elif is_unsigned_int(f.base_type): write_deserialize_bits(s, v, NUM_BYTES[f.base_type]) else: raise ValueError('%s unknown'%f.base_type) def write_deserialize_field(s, f, pkg): slot = '(cl:slot-value msg \'%s)'%f.name var = slot if f.is_array: if not f.array_len: write_deserialize_length(s, True) length = '__ros_arr_len' else: length = '%s'%f.array_len s.write('(cl:setf %s (cl:make-array %s))'%(slot, length)) s.write('(cl:let ((vals %s))'%slot) # t2 var = '(cl:aref vals i)' with Indent(s): s.write('(cl:dotimes (i %s)'%length) if f.is_builtin: with Indent(s): write_deserialize_builtin(s, f, var) else: if f.is_array: with Indent(s): s.write('(cl:setf %s (cl:make-instance \'%s))'%(var, msg_type(f))) s.write('(roslisp-msg-protocol:deserialize %s istream)'%var) if f.is_array: s.write('))', False) if not f.array_len: s.write(')', False) def write_deserialize(s, spec): """ Write the deserialize method """ s.write('(cl:defmethod roslisp-msg-protocol:deserialize ((msg %s) istream)'%message_class(spec)) with Indent(s): s.write('"Deserializes a message object of type \'%s"'%message_class(spec)) for f in spec.parsed_fields(): write_deserialize_field(s, f, spec.package) s.write('msg') s.write(')') def write_class_exports(s, pkg): "Write the _package.lisp file" s.write('(cl:defpackage %s-msg'%pkg, False) with Indent(s): s.write('(:use )') s.write('(:export') with Indent(s, inc=1): for spec in roslib.msgs.get_pkg_msg_specs(pkg)[0]: (p, msg_type) = spec[0].split('/') msg_class = '<%s>'%msg_type s.write('"%s"'%msg_class.upper()) s.write('"%s"'%msg_type.upper()) s.write('))\n\n') def write_srv_exports(s, pkg): "Write the _package.lisp file for a service directory" s.write('(cl:defpackage %s-srv'%pkg, False) with Indent(s): s.write('(:use )') s.write('(:export') with Indent(s, inc=1): for spec in roslib.srvs.get_pkg_srv_specs(pkg)[0]: (_, srv_type) = spec[0].split('/') s.write('"%s"'%srv_type.upper()) s.write('"<%s-REQUEST>"'%srv_type.upper()) s.write('"%s-REQUEST"'%srv_type.upper()) s.write('"<%s-RESPONSE>"'%srv_type.upper()) s.write('"%s-RESPONSE"'%srv_type.upper()) s.write('))\n\n') def write_asd_deps(s, deps, msgs): with Indent(s): s.write(':depends-on (:roslisp-msg-protocol :roslisp-utils ') with Indent(s, inc=13, indent_first=False): for d in sorted(deps): s.write(':%s-msg'%d) s.write(')') #t2 indentation with Indent(s): s.write(':components ((:file "_package")') with Indent(s): for (full_name, _) in msgs: (_, name) = full_name.split('/') s.write('(:file "%s" :depends-on ("_package_%s"))'%(name, name)) s.write('(:file "_package_%s" :depends-on ("_package"))'%name) s.write('))') def write_srv_asd(s, pkg): s.write('(cl:in-package :asdf)') s.newline() s.write('(defsystem "%s-srv"'%pkg) services = roslib.srvs.get_pkg_srv_specs(pkg)[0] # Figure out set of depended-upon ros packages deps = set() for (_, spec) in services: for f in spec.request.parsed_fields(): if not f.is_builtin: (p, _) = parse_msg_type(f) deps.add(p) for f in spec.response.parsed_fields(): if not f.is_builtin: (p, _) = parse_msg_type(f) deps.add(p) write_asd_deps(s, deps, services) def write_asd(s, pkg): s.write('(cl:in-package :asdf)') s.newline() s.write('(defsystem "%s-msg"'%pkg) msgs = roslib.msgs.get_pkg_msg_specs(pkg)[0] # Figure out set of depended-upon ros packages deps = set() for (_, spec) in msgs: for f in spec.parsed_fields(): if not f.is_builtin: (p, _) = parse_msg_type(f) deps.add(p) if pkg in deps: deps.remove(pkg) write_asd_deps(s, deps, msgs) def write_accessor_exports(s, spec): "Write the package exports for this message/service" is_srv = isinstance(spec, SrvSpec) suffix = 'srv' if is_srv else 'msg' s.write('(cl:in-package %s-%s)'%(spec.package, suffix), indent=False) s.write('(cl:export \'(') if is_srv: fields = spec.request.parsed_fields()[:] fields.extend(spec.response.parsed_fields()) else: fields = spec.parsed_fields() with Indent(s, inc=10, indent_first=False): for f in fields: accessor = '%s-val'%f.name s.write('%s'%accessor.upper()) s.write('%s'%f.name.upper()) s.write('))') def write_ros_datatype(s, spec): for c in (message_class(spec), new_message_class(spec)): s.write('(cl:defmethod roslisp-msg-protocol:ros-datatype ((msg (cl:eql \'%s)))'%c) with Indent(s): s.write('"Returns string type for a %s object of type \'%s"'%(spec.component_type, c)) s.write('"%s")'%spec.full_name) def write_md5sum(s, spec, parent=None): if parent is None: parent = spec gendeps_dict = roslib.gentools.get_dependencies(parent, spec.package, compute_files=False) md5sum = roslib.gentools.compute_md5(gendeps_dict) for c in (message_class(spec), new_message_class(spec)): s.write('(cl:defmethod roslisp-msg-protocol:md5sum ((type (cl:eql \'%s)))'%c) with Indent(s): # t2 this should print 'service' instead of 'message' if it's a service request or response s.write('"Returns md5sum for a message object of type \'%s"'%c) s.write('"%s")'%md5sum) def write_message_definition(s, spec): for c in (message_class(spec), new_message_class(spec)): s.write('(cl:defmethod roslisp-msg-protocol:message-definition ((type (cl:eql \'%s)))'%c) with Indent(s): s.write('"Returns full string definition for message of type \'%s"'%c) s.write('(cl:format cl:nil "') gendeps_dict = roslib.gentools.get_dependencies(spec, spec.package, compute_files=False) definition = roslib.gentools.compute_full_text(gendeps_dict) lines = definition.split('\n') for line in lines: l = line.replace('\\', '\\\\') l = l.replace('"', '\\"') s.write('%s~%%'%l, indent=False) s.write('~%', indent=False) s.write('"))', indent=False) def write_builtin_length(s, f, var='msg'): if f.base_type in ['int8', 'uint8']: s.write('1') elif f.base_type in ['int16', 'uint16']: s.write('2') elif f.base_type in ['int32', 'uint32', 'float32']: s.write('4') elif f.base_type in ['int64', 'uint64', 'float64', 'duration', 'time']: s.write('8') elif f.base_type == 'string': s.write('4 (cl:length %s)'%var) elif f.base_type in ['bool', 'byte', 'char']: s.write('1') else: raise ValueError('Unknown: %s', f.base_type) def write_serialization_length(s, spec): c = message_class(spec) s.write('(cl:defmethod roslisp-msg-protocol:serialization-length ((msg %s))'%c) with Indent(s): s.write('(cl:+ 0') with Indent(s, 3): for field in spec.parsed_fields(): slot = '(cl:slot-value msg \'%s)'%field.name if field.is_array: l = '0' if field.array_len else '4' s.write('%s (cl:reduce #\'cl:+ %s :key #\'(cl:lambda (ele) (cl:declare (cl:ignorable ele)) (cl:+ '%(l, slot)) var = 'ele' s.block_next_indent() else: var = slot if field.is_builtin: write_builtin_length(s, field, var) else: s.write('(roslisp-msg-protocol:serialization-length %s)'%var) if field.is_array: s.write(')))', False) s.write('))') def write_list_converter(s, spec): c = message_class(spec) s.write('(cl:defmethod roslisp-msg-protocol:ros-message-to-list ((msg %s))'%c) with Indent(s): s.write('"Converts a ROS message object to a list"') s.write('(cl:list \'%s'%new_message_class(spec)) with Indent(s): for f in spec.parsed_fields(): s.write('(cl:cons \':%s (%s msg))'%(f.name, f.name)) s.write('))') def write_constants(s, spec): if spec.constants: for cls in (message_class(spec), new_message_class(spec)): s.write('(cl:defmethod roslisp-msg-protocol:symbol-codes ((msg-type (cl:eql \'%s)))'%cls) with Indent(s): s.write(' "Constants for message type \'%s"'%cls) s.write('\'(') with Indent(s, indent_first=False): for c in spec.constants: s.write('(:%s . %s)'%(c.name.upper(), c.val)) s.write(')', False) s.write(')') def write_srv_component(s, spec, parent): spec.component_type='service' write_html_include(s, spec) write_defclass(s, spec) write_deprecated_readers(s, spec) write_constants(s, spec) write_serialize(s, spec) write_deserialize(s, spec) write_ros_datatype(s, spec) write_md5sum(s, spec, parent) write_message_definition(s, spec) write_serialization_length(s, spec) write_list_converter(s, spec) def write_service_specific_methods(s, spec): spec.actual_name=spec.short_name s.write('(cl:defmethod roslisp-msg-protocol:service-request-type ((msg (cl:eql \'%s)))'%spec.short_name) with Indent(s): s.write('\'%s)'%new_message_class(spec.request)) s.write('(cl:defmethod roslisp-msg-protocol:service-response-type ((msg (cl:eql \'%s)))'%spec.short_name) with Indent(s): s.write('\'%s)'%new_message_class(spec.response)) s.write('(cl:defmethod roslisp-msg-protocol:ros-datatype ((msg (cl:eql \'%s)))'%spec.short_name) with Indent(s): s.write('"Returns string type for a service object of type \'%s"'%message_class(spec)) s.write('"%s")'%spec.full_name) def generate_msg(msg_path): """ Generate a message @param msg_path: The path to the .msg file @type msg_path: str """ (package_dir, package) = roslib.packages.get_dir_pkg(msg_path) (_, spec) = roslib.msgs.load_from_file(msg_path, package) spec.actual_name=spec.short_name spec.component_type='message' ######################################## # 1. Write the .lisp file ######################################## io = StringIO() s = IndentedWriter(io) write_begin(s, spec, msg_path) write_html_include(s, spec) write_defclass(s, spec) write_deprecated_readers(s, spec) write_constants(s, spec) write_serialize(s, spec) write_deserialize(s, spec) write_ros_datatype(s, spec) write_md5sum(s, spec) write_message_definition(s, spec) write_serialization_length(s, spec) write_list_converter(s, spec) output_dir = '%s/msg_gen/lisp'%package_dir if (not os.path.exists(output_dir)): # if we're being run concurrently, the above test can report false but os.makedirs can still fail if # another copy just created the directory try: os.makedirs(output_dir) except OSError as e: pass with open('%s/%s.lisp'%(output_dir, spec.short_name), 'w') as f: f.write(io.getvalue() + "\n") io.close() ######################################## # 2. Write the _package file # for this message ######################################## io = StringIO() s = IndentedWriter(io) write_accessor_exports(s, spec) with open('%s/_package_%s.lisp'%(output_dir, spec.short_name), 'w') as f: f.write(io.getvalue()) io.close() ######################################## # 3. Write the _package.lisp file # This is being rewritten once per msg # file, which is inefficient ######################################## io = StringIO() s = IndentedWriter(io) write_class_exports(s, package) with open('%s/_package.lisp'%output_dir, 'w') as f: f.write(io.getvalue()) io.close() ######################################## # 4. Write the .asd file # This is being written once per msg # file, which is inefficient ######################################## io = StringIO() s = IndentedWriter(io) write_asd(s, package) with open('%s/%s-msg.asd'%(output_dir, package), 'w') as f: f.write(io.getvalue()) io.close() # t0 most of this could probably be refactored into being shared with messages def generate_srv(srv_path): "Generate code from .srv file" (pkg_dir, pkg) = roslib.packages.get_dir_pkg(srv_path) (_, spec) = roslib.srvs.load_from_file(srv_path, pkg) output_dir = '%s/srv_gen/lisp'%pkg_dir if (not os.path.exists(output_dir)): # if we're being run concurrently, the above test can report false but os.makedirs can still fail if # another copy just created the directory try: os.makedirs(output_dir) except OSError as e: pass ######################################## # 1. Write the .lisp file ######################################## io = StringIO() s = IndentedWriter(io) write_begin(s, spec, srv_path, True) spec.request.actual_name='%s-request'%spec.short_name spec.response.actual_name='%s-response'%spec.short_name write_srv_component(s, spec.request, spec) s.newline() write_srv_component(s, spec.response, spec) write_service_specific_methods(s, spec) with open('%s/%s.lisp'%(output_dir, spec.short_name), 'w') as f: f.write(io.getvalue()) io.close() ######################################## # 2. Write the _package file # for this service ######################################## io = StringIO() s = IndentedWriter(io) write_accessor_exports(s, spec) with open('%s/_package_%s.lisp'%(output_dir, spec.short_name), 'w') as f: f.write(io.getvalue()) io.close() ######################################## # 3. Write the _package.lisp file ######################################## io = StringIO() s = IndentedWriter(io) write_srv_exports(s, pkg) with open('%s/_package.lisp'%output_dir, 'w') as f: f.write(io.getvalue()) io.close() ######################################## # 4. Write the .asd file ######################################## io = StringIO() s = IndentedWriter(io) write_srv_asd(s, pkg) with open('%s/%s-srv.asd'%(output_dir, pkg), 'w') as f: f.write(io.getvalue()) io.close() if __name__ == "__main__": roslib.msgs.set_verbose(False) if sys.argv[1].endswith('.msg'): generate_msg(sys.argv[1]) elif sys.argv[1].endswith('.srv'): generate_srv(sys.argv[1]) else: raise ValueError('Invalid filename %s'%sys.argv[1]) roslisp-1.9.20/roslisp-msg-protocol/000077500000000000000000000000001270365674000174265ustar00rootroot00000000000000roslisp-1.9.20/roslisp-msg-protocol/msg-protocol.lisp000066400000000000000000000141411270365674000227450ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package roslisp-msg-protocol) (defclass ros-message () ()) (defgeneric serialize (msg str) (:documentation "Serialize message object MSG onto stream STR.")) (defgeneric deserialize (msg str) (:documentation "Deserialize from stream STR into message object MSG and also returns MSG. MSG may also be a symbol naming a message type, in which case a new object of that type is created and returned.")) (defgeneric serialization-length (msg) (:documentation "Length of this message")) (defgeneric md5sum (msg-type) (:documentation "Return the md5 sum of this message type.")) (defgeneric ros-datatype (msg-type) (:documentation "Return the datatype given a message type, service type, service request or response type, or topic name")) (defgeneric message-definition (msg-type) (:documentation "Return the definition of this message type")) (defgeneric service-request-type (srv)) (defgeneric service-response-type (srv)) (defgeneric symbol-codes (msg-type) (:documentation "Return an association list from symbols to numbers (the const declarations in the .msg file). `msg-type' is either a symbol naming the message class or an instance of the class.")) (defgeneric symbol-code (msg-type symbol) (:documentation "symbol-code MSG-TYPE SYMBOL. Gets the value of a message-specific constant declared in a msg file. The first argument is either a symbol naming the message class, or an instance of the class, and the second argument is the keyword symbol corresponding to the constant name. For example, to get the value of the DEBUG constant from Log.msg, use (symbol-code ' :debug).")) (defgeneric code-symbols (msg-type code) (:documentation "Retrieves the list of symbol-code associations which contain `code' within `msg-type'. `msg-type' is a either a symbol naming the message class or an instance of that class. `code' is an integer. For example, if my_msgs/Log.msg has defined the constants DEBUG=1, WARN=2, ERROR=1, you can get all code-symbol associations with constant code 1 with: ROSLISP-MSG-PROTOCOL> (code-symbols 'my_msgs-msg:log 1) ((:DEBUG . 1) (:ERROR . 1))")) (defgeneric code-symbol (msg-type code) (:documentation "Retrieves the first symbol associated with the constant `code' in the symbol codes of `msg-type'. If no such association exists, it returns NIL. `msg-type' is a either a symbol naming the message class or an instance of that class. `code' is an integer. For example, if my_msgs/Log.msg has defined the constants DEBUG=1, WARN=2, ERROR=1, you can get the first symbol associated with the constant code 1 with: ROSLISP-MSG-PROTOCOL> (code-symbol 'my_msgs-msg:log 1) :DEBUG")) (defgeneric ros-message-to-list (msg) (:documentation "Return a structured list representation of the message. For example, say message type foo has a float field x equal to 42, and a field y which is itself a message of type bar, which has a single field z=24. This function would then return the structured list '(foo (:x . 42.0) (:y . (bar (:z . 24)))). The return value can be passed to list-to-ros-message to retrieve an equivalent message to the original. As a base case, non-ros messages just return themselves.")) (defgeneric list-to-ros-message (l)) (defvar *print-deprecation-warnings* t) (defvar *warnings-table* (make-hash-table :test 'eq)) (defmacro msg-deprecation-warning (str &rest args) (let ((x (gensym))) `(unless (gethash ',x *warnings-table*) (when *print-deprecation-warnings* (warn ,str ,@args)) (setf (gethash ',x *warnings-table*) t) ) )) ;; datatype functions for string arguments (defun string-to-ros-msgtype-symbol (msg-type) "returns the symbol of a know ros messagetype if the string matches the the name case sensitively, else throws error" (assert (= 1 (count #\/ msg-type)) () "Too few or too many slashes in \"~a\"" msg-type) (let* ((slashpos (position #\/ msg-type)) (type-symbol (find-symbol (string-upcase (subseq msg-type (1+ slashpos) (length msg-type))) (string-upcase (concatenate 'string (subseq msg-type 0 slashpos) "-MSG")))) (truename (unless (null type-symbol) (ros-datatype type-symbol)))) (when (null type-symbol) (error "No datatype ~a known" msg-type)) (unless (string= truename msg-type) (error "Case mismatch for message type ~a, did you mean ~a?" msg-type truename)) type-symbol))roslisp-1.9.20/roslisp-msg-protocol/package.lisp000066400000000000000000000044431270365674000217170ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :roslisp-msg-protocol (:use :cl) (:export :ros-message :serialize :deserialize :serialization-length :md5sum :ros-datatype :message-definition :service-request-type :service-response-type :symbol-codes :symbol-code :code-symbols :code-symbol :string-to-ros-msgtype-symbol :ros-message-to-list :list-to-ros-message :msg-deprecation-warning)) roslisp-1.9.20/roslisp-msg-protocol/roslisp-msg-protocol.asd000066400000000000000000000002311270365674000242310ustar00rootroot00000000000000 (in-package :asdf) (defsystem :roslisp-msg-protocol :name "roslisp-msg" :serial t :components ((:file "package") (:file "msg-protocol"))) roslisp-1.9.20/roslisp.dox000066400000000000000000000226411270365674000155240ustar00rootroot00000000000000/** \mainpage \htmlinclude manifest.html \section Overview \b roslisp is a library for writing ROS nodes in ANSI Common Lisp. See the tutorial at for how to set up roslisp for standalone compilation of lisp source files and/or interactive use. This page lists the functions available in the client library and other miscellaneous information. Detailed documentation about the functions is available within the Lisp environment using the documentation feature. \section build Integration with build system Roslisp is integrated with the asdf build system. When using roslisp nodes from within a lisp environment, add the following lines to your .sbclrc: \verbatim (push #P"/path/to/roslisp/asdf/" asdf:*central-registry*) (asdf:operate 'asdf:load-op :ros-load-manifest) \endverbatim This extends asdf to use two additional rospack-based search methods to finding .asd files. - Given a system name foo, if the variable ros-load:*current-ros-package* is a nonempty string, it will look for a system named foo defined in asdf/foo.asd of the package or one of its ros dependencies. The file asdf/foo.asd will usually be a symbolic link to a file in whatever directory the actual source files are in. To dynamically bind the variable ros-load:*current-ros-package* and perform the load operation, the function ros-load:load-system can be used. It takes the name of the ros package as first parameter and an optional second parameter for the name of the system to load, which defaults to the ros package name. - Given a system of the form foo-msg, if there's a ros package called foo, the messages from this package will be loaded, and likewise for foo-srv and services. You can also build standalone nodes in the CMakeLists.txt file. For example, roslisp_examples/CMakeLists.txt contains \verbatim rospack_add_lisp_executable(bin/talker roslisp-examples roslisp-talker:main) \endverbatim This produces the executable roslisp_examples/bin/talker when built. When run from the command line, the executable does not load your standard .sbclrc init file. Rather, it loads ~/.sbclrc-roslisp (if it exists). It then sets *current-ros-package* to roslisp_examples, and loads the asdf system roslisp-examples into memory (using rospack). Next, it loads the files bin/roslisp-init.lisp and bin/roslisp-talker:main.init.lisp (if they exist). These are the places where you can put global, package-specific, and node-specific runtime customizations (customizing debug levels, setting optimization flags, modifying constants) respectively. Finally, it calls the function roslisp-talker:main. Also, when running standalone, the keyword :roslisp-standalone-executable is pushed on to the *features* list, in case you want to make use of this information in some way. Finally, setting the ROSLISP_BACKTRACE_ON_ERRORS environment variable before running the node will print debugging info if it dies. \section emacs Integration into emacs The current trunk version of the rosemacs package contains a slime contrib that adds a slime repl shortcut to load systems in ros packages. Please see the rosemacs documentation for more information. \section debug Debugging output Roslisp provides a hierarchical, customizable-at-runtime, logging scheme, similar to rosconsole for roscpp. Debug topics are lists, e.g. (roslisp top). For such a topic, the debug level of (roslisp top) would be looked up. If this is not present (roslisp) is looked up. If this is not present, () is looked up (and this is always present in the topic list). The level at runtime then determines whether the message is evaluated and outputted (to stdout and rosout). To set debug levels, from within Lisp use set-debug-levels. To produce debugging output, use ros-{debug|info|warn|error|fatal}. Additionally, debug levels correspond to ros parameters, e.g., topic (foo bar) corresponds to the private parameter ~debug/foo/bar/level. Upon node initialization, these are read from the parameter server, and must be one of the five strings debug, info, warn, error, or fatal. If they are changed after node startup, call the node's ~reset-debug-levels service to update. A more permanent way to update debug levels is to call set-debug-levels in an initialization file. Roslisp itself uses debugging levels starting with :roslisp, with subtopics such as :top, :tcp, and :rosout. For example, if debugging roslisp_examples/bin/talker, add the following line to roslisp_examples/bin/roslisp-init.lisp: \verbatim (roslisp:set-debug-levels roslisp :debug) \endverbatim To reduce the number of connection-related debugging messages, also add the line \verbatim (roslisp:set-debug-levels (roslisp tcp) :info) \endverbatim \section Packages The functions in the client API below belong to the Lisp package (namespace) named :roslisp, with the exception of the constructors and field accessors for ROS message data types, which belong to a Lisp package with the same name as the message's ROS package concatenated with "-msg" (and likewise for services, with the suffix "-srv"). \section Names Names (of topics, services, and parameters) are handled according to standard ROS conventions. Command-line arguments to the executable, of the form foo:=bar, where foo does not begin with '_', are known as command line remappings. Given such a remapping, any topic, parameter, or service referred to as foo in the node's code would then be replaced by bar. The node name is given by the argument to start-ros-node or with-ros-node. It can, however, be overridden by including a command-line argument of the form __name=foo. The namespace is set as follows: if there is a command-line argument __ns:=foo, the namespace is foo. If not, and if the environment variable ROS_NAMESPACE is set to bar, the namespace is bar. If not, the namespace is /. All commands below that take a name of a topic, service, or parameter can be given an absolute (/foo/bar/baz), relative (baz/qux), or private (~qux) name. \section startstop Starting and stopping a node See documentation for functions start-ros-node, shutdown-ros-node, and with-ros-node. \section topic Topics See functions advertise, subscribe, publish, publish-msg. \section services Services See functions call-service, def-service-callback, register-service, register-service-fn, wait-for-service, make-request. \section params Parameters See functions get-param, set-param, has-param, delete-param. \section node Node information See function node-status. \section misc Miscellaneous functions See make-uri, fully-qualified-name, loop-at-most-every, ros-time, \section types Message data types Each ROS message type has a corresponding Lisp class and operations on it. A message type foo in ROS package bar corresponds to a Lisp class named in the bar-msg Lisp package. If your code will create or operate on objects of this type, it should contain the form (roslisp:load-message-types "bar/foo"). Operations in the message's package: - An object of type in package bar-msg, with initial value of field baz equal to 3, is created using (make-instance 'bar-msg: :baz 3). - Given a field named baz in an object m of the above message type, it can be read using (bar-msg:baz-val m). However, it is recommended that you use the list operations below such as with-fields, unless this is slowing your code down. The roslisp Lisp package contains some additional generic operations that work on any message: - symbol-code M S. M is either a message or the name of a message class. S is a keyword symbol naming a constant declaration in the .msg file. Returns the value of the constant. For example, to get the value of the DEBUG constant in roslib/Log.msg, use (symbol-code 'roslib-msg: :debug) or (symbol-code m :debug) where m is an instance of '. - ros-message-to-list MSG - list-to-ros-message L - pprint-ros-message STREAM MSG prints the message to the given stream in human-readable format. This is also set as the default dispatch function for ROS messages in Lisp's pretty printer. So if you have pretty printing turned on, and call a function from the prompt that returns a ROS message, that return value will be printed human-readably using pprint-ros-message. Similarly, if your code contains something like (format t "The message is ~a" m), that will DTRT. There are a few additional operations that use the list representation of ros messages, and are therefore less efficient, but more readable and convenient for interactive use. See with-fields, make-message, modify-message-copy, and setf-msg. IMPORTANT: message objects are assumed to be immutable; this assumption may be used in future to cache various things. In other words, if m is a variable that refers to some message object, don't do something like (setf (slot-value m 'my-field) 42). Instead, in this situation, do something like (setf-msg m 'my-field 42) (of course, it's always legal to do something like (setq m (function-that-returns-new-message-object)) since that just changes what m refers to rather than modifying the pointed-to object). When constructing messages, either use the form (make-instance ' :field1 42 :field24) or (make-msg "my_package/Foo" :field1 42 :field2 24). Don't use the C++-inspired way of first creating the object then setting its fields. \section servicetypes Service Data Types Given a ROS service type qux in the bar ROS package, there are corresponding message types and in the bar-srv Lisp package. The request and response messages can be operated on like any other message. */ roslisp-1.9.20/s-xml-rpc/000077500000000000000000000000001270365674000151325ustar00rootroot00000000000000roslisp-1.9.20/s-xml-rpc/ChangeLog000066400000000000000000000024351270365674000167100ustar00rootroot000000000000002004-06-17 Rudi Schlatte * src/package.lisp: Add system.getCapabilities. * src/extensions.lisp: Create, move server extensions from xml-rpc.lisp here. (do-one-multicall): Raise standard fault codes. (|system.getCapabilities|): Implement. * src/xml-rpc.lisp: Remove server extensions. (encode-xml-rpc-value): Encode symbols as strings (execute-xml-rpc-call, handle-xml-rpc-call): Raise standard fault codes. 2004-06-13 Rudi Schlatte * src/xml-rpc.lisp (xml-literal): new datatype for unescaped strings (used by system.multicall to pass back encoded fault structs) (encode-xml-rpc-value): handle it. (encode-xml-rpc-fault-value, encode-xml-rpc-fault): separate encoding of fault and methodResponse for system.multicall (do-one-multicall, |system.multicall|): Implement system.multicall. * src/package.lisp (s-xml-rpc-exports): New package -- don't export the whole common-lisp package by default ;) * src/xml-rpc.lisp (*xml-rpc-package*): ... use it. * src/xml-rpc.lisp (|system.listMethods|) (|system.methodSignature|, |system.methodHelp|): Added introspection methods, to be imported in *xml-rpc-package*. * src/package.lisp (s-xml-rpc): ... export them, and also |system.multicall| * src/xml-rpc.lisp: Some indentation frobs. roslisp-1.9.20/s-xml-rpc/Makefile000066400000000000000000000020061270365674000165700ustar00rootroot00000000000000default: @echo Possible targets: @echo clean-openmcl --- remove all '*.dfsl' recursively @echo clean-lw --- remove all '*.nfasl' recursively @echo clean-emacs --- remove all '*~' recursively @echo clean --- all of the above clean-openmcl: find . -name "*.dfsl" | xargs rm clean-lw: find . -name "*.nfasl" | xargs rm clean-emacs: find . -name "*~" | xargs rm clean: clean-openmcl clean-lw clean-emacs # # This can obviously only be done by a specific person in a very specific context ;-) # PRJ=s-xml-rpc ACCOUNT=scaekenberghe CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot release: rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html mv /tmp/public_html /tmp/$(PRJ)/doc cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html roslisp-1.9.20/s-xml-rpc/doc/000077500000000000000000000000001270365674000156775ustar00rootroot00000000000000roslisp-1.9.20/s-xml-rpc/doc/S-XML-RPC.html000066400000000000000000000202121270365674000200440ustar00rootroot00000000000000S-XML-RPC

API for package S-XML-RPC

An implementation of the standard XML-RPC protocol for both client and server

*xml-rpc-agent*   variable

String specifying the default XML-RPC agent to include in server responses
Initial value: "LispWorks 4.3.7"

*xml-rpc-authorization*   variable

When not null, a string to be used as Authorization header
Initial value: NIL

*xml-rpc-call-hook*   variable

A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list
Initial value: EXECUTE-XML-RPC-CALL

*xml-rpc-debug*   variable

When T the XML-RPC client and server part will be more verbose about their protocol
Initial value: NIL

*xml-rpc-debug-stream*   variable

When not nil it specifies where debugging output should be written to
Initial value: NIL

*xml-rpc-host*   variable

String naming the default XML-RPC host to use
Initial value: "localhost"

*xml-rpc-package*   variable

Package for XML-RPC callable functions
Initial value: #

*xml-rpc-port*   variable

Integer specifying the default XML-RPC port to use
Initial value: 80

*xml-rpc-proxy-host*   variable

When not null, a string naming the XML-RPC proxy host to use
Initial value: NIL

*xml-rpc-proxy-port*   variable

When not null, an integer specifying the XML-RPC proxy port to use
Initial value: NIL

*xml-rpc-url*   variable

String specifying the default XML-RPC URL to use
Initial value: "/RPC2"

(call-xml-rpc-server server-keywords name &rest args)   function

Encode and execute an XML-RPC call with name and args, using the list of server-keywords

(encode-xml-rpc-call name &rest args)   function

Encode an XML-RPC call with name and args as an XML string

(execute-xml-rpc-call method-name &rest arguments)   function

Execute method METHOD-NAME on ARGUMENTS, or raise an error if no such method exists in *XML-RPC-PACKAGE*

(get-xml-rpc-struct-member struct member)   function

Get the value of a specific member of an XML-RPC-STRUCT

(setf (get-xml-rpc-struct-member struct member) value)   function

Set the value of a specific member of an XML-RPC-STRUCT

(start-xml-rpc-server &key (port *xml-rpc-port*) (url *xml-rpc-url*) (agent *xml-rpc-agent*))   function

Start an XML-RPC server in a separate process

(stop-server name)   function

Kill a server process by name (as started by start-standard-server)

(system.listmethods)   function

List the methods that are available on this server.

(system.methodhelp method-name)   function

Returns the function documentation for the given method.

(system.methodsignature method-name)   function

Dummy system.methodSignature implementation. There's no way to get (and no concept of) required argument types in Lisp, so this function always returns nil or errors.

(system.multicall calls)   function

Implement system.multicall; see http://www.xmlrpc.com/discuss/msgReader$1208 for the specification.

(xml-rpc-call encoded &key (url *xml-rpc-url*) (agent *xml-rpc-agent*) (host *xml-rpc-host*) (port *xml-rpc-port*) (authorization *xml-rpc-authorization*) (proxy-host *xml-rpc-proxy-host*) (proxy-port *xml-rpc-proxy-port*))   function

Execute an already encoded XML-RPC call and return the decoded result

xml-rpc-condition   condition

Parent condition for all conditions thrown by the XML-RPC package
Class precedence list: xml-rpc-condition error serious-condition condition standard-object t

xml-rpc-error   condition

This condition is thrown when an XML-RPC protocol error occurs
Class precedence list: xml-rpc-error xml-rpc-condition error serious-condition condition standard-object t
Class init args: :data :code

(xml-rpc-error-data xml-rpc-error)   generic-function

Get the data from an XML-RPC error

(xml-rpc-error-place xml-rpc-error)   generic-function

Get the place from an XML-RPC error

xml-rpc-fault   condition

This condition is thrown when the XML-RPC server returns a fault
Class precedence list: xml-rpc-fault xml-rpc-condition error serious-condition condition standard-object t
Class init args: :string :code

(xml-rpc-fault-code xml-rpc-fault)   generic-function

Get the code from an XML-RPC fault

(xml-rpc-fault-string xml-rpc-fault)   generic-function

Get the string from an XML-RPC fault

xml-rpc-struct   structure

An XML-RPC-STRUCT is an associative map of member names and values

(xml-rpc-struct &rest args)   function

Create a new XML-RPC-STRUCT from the arguments: alternating member names and values

(xml-rpc-struct-alist object)   function

Return the alist of member names and values from an XML-RPC struct

(xml-rpc-struct-equal struct1 struct2)   function

Compare two XML-RPC-STRUCTs for equality

(xml-rpc-struct-p object)   function

Return T when the argument is an XML-RPC struct

xml-rpc-time   structure

A wrapper around a Common Lisp universal time to be interpreted as an XML-RPC-TIME

(xml-rpc-time &optional (universal-time (get-universal-time)))   function

Create a new XML-RPC-TIME struct with the universal time specified, defaulting to now

(xml-rpc-time-p object)   function

Return T when the argument is an XML-RPC time

(xml-rpc-time-universal-time object)   function

Return the universal time from an XML-RPC time

Documentation generated by lispdoc running on LispWorks

 roslisp-1.9.20/s-xml-rpc/doc/index.html000066400000000000000000000300041270365674000176710ustar00rootroot00000000000000 S-XML-RPC

S-XML-RPC

S-XML-RPC is an implementation of XML-RPC in Common Lisp for both client and server. Originally it was written by Sven Van Caekenberghe. It is now being maintained by Sven Van Caekenberghe, Rudi Schlatte and Brian Mastenbrook. S-XML-RPC is using S-XML as parser.

XML-RPC is a de facto standard for making remote procedure calls between software running on disparate operating systems, running in different environments and implemented using different languages. XML-RPC is using HTTP as the transport and XML as the encoding. XML-RPC is designed to be as simple as possible, while allowing complex data structures to be transmitted, processed and returned. The protocol is described in detail on http://www.xmlrpc.com/. Some key features (both positive and negative) of the XML-RPC protocol are:

  • It is a published protocol implemented in a variety of languages and operating systems.
  • It allows communication between applications implemented in different languages.
  • It allows communication over the internet and through firewalls.
  • It is not intended for time-critical communications, or for the transmission of large volumes of data.
  • It is an asymmetrical protocol allowing calls from the client to the server but not callbacks from the server to the client.
  • It is a very simple protocol that it not defined, controlled or endorsed by a standards body.
  • It works.

Download

You can download the LLGPL source code and documentation as s-xml-rpc.tgz (signature: s-xml-rpc.tgz.asc for which the public key can be found in the common-lisp.net keyring) (build and/or install with ASDF). There is also CVS access.

API

The plain API exported by the package S-XML-RPC (automatically generated by LispDoc) is available in S-XML-RPC.html.

Usage

Client

Making an XML-RPC call is a two step process: first you encode the call, then you make the call. 

? (xml-rpc-call (encode-xml-rpc-call "currentTime.getCurrentTime") :host "time.xmlrpc.com")
#<XML-RPC-TIME 20021216T06:36:33>

? (xml-rpc-call (encode-xml-rpc-call "examples.getStateName" 41) :host "betty.userland.com")
"South Dakota"
If you are behind an HTTP proxy, you have to pass that information along using keyword arguments. For all keyword arguments, there are default global variables (because most of the time you talk to the same host). 
? (xml-rpc-call (encode-xml-rpc-call "currentTime.getCurrentTime") :host "time.xmlrpc.com" 
                                                                   :proxy-host "myproxy" 
                                                                   :proxy-port 8080)
When all goes well, an XML-RPC call returns a result that is decoded into a Common Lisp value. A number of things can go wrong:
  • There could be a problem encoding the call.
  • There could be a problem in the networking, up to the HTTP server responding with a code different from 200 OK.
  • The result of the call could be an XML-RPC fault: this is how the server responds to an error that occured on the server while executing the call there.
  • There could be a problem decoding the call's result.
At the moment, all these cases are reported by the standard error mechanism. Later we could use different condition types. There are two structs, xml-rpc-time and xml-rpc-struct, that represent two XML-RPC types, iso8601.dateTime and struct respectively. Two convenience functions with the same name come in handy when creating these structs: 
? (xml-rpc-struct :foo 1 :bar -1)
#<#XML-RPC-STRUCT (:BAR . -1) (:FOO . 1)>
	
? (xml-rpc-time 3000000000)
#<XML-RPC-TIME 19950125T06:20:00>
The function xml-rpc-aserve:xml-rpc-call-aserve does the same thing, but uses the (portable) aserve HTTP client API for the networking.

The unit tests in the subdirectory test can serve as (executable) examples. A more complicated example is the server and client implementation of some tests in validator1.lisp. Remember that XML-RPC method (function) names are case-sensitive, as are the names of XML-RPC structure members.

Server

Only a single function call is needed to get the server up and running: 

? (start-xml-rpc-server :port 8080)
From now on, your lisp image becomes an XML-RPC server, listening for HTTP requests on port 8080. By default the functions system.listMethods, system.methodSignature, system.methodHelp and system.multicall are available. You can export additional functions from the server by importing symbols in the package contained in *xml-rpc-package* (by default, this is the package S-XML-RPC-EXPORTS). (use-package :common-lisp :s-xml-rpc-exports) makes all of Common Lisp available via xml-rpc.

In more detail, this is what happens:

  • The XML-RPC call arrives as XML encoded characters in the body of an HTTP POST request
  • The characters received are parsed by the XML parser and decoded on the fly (using a SAX-like interface) following XML-RPC semantics into a a string method name and a possibly empty list of Lisp objects that are the arguments
  • The value of *xml-rpc-call-hook* is applied on the string method name and optional argument list
  • The default value of *xml-rpc-call-hook* is execute-xml-rpc-call which looks for a function with the given name in the package *xml-rpc-package* (whose default value is the XML-RPC-EXPORTS package) and applies the function bound to that name to the argument list (if any)
  • The result is encoded as an XML-RPC result and returned to the client
  • If anything goes wrong in any of these steps, a Lisp condition is thrown which is caught and then encoded as an XML-RPC fault and returned to the client
Customization points are *xml-rpc-package* and *xml-rpc-call-hook*. Setting the variable xml-rpc::*xml-rpc-debug* to t makes the server more verbose. Note that XML-RPC method names are case sensitive: for example, clients have specify "LISP-IMPLEMENTATION-TYPE" for the corresponding Lisp function; a server has to define a function named |login| if his clients look for an implementation of "login".

AppleScript can make client-side XML-RPC calls. So provided you have your lisp XML-RPC server running and have imported + in XML-RPC-EXPORTS, you can have lisp do the math like this: 

tell application "http://localhost:8080/RPC2"
  set call_result to call xmlrpc {method name:"+", parameters:{10, 20, 30}}
end tell
display dialog the call_result buttons {"OK"}
Calling the functions xml-rpc-aserve:start-xml-rpc and xml-rpc-aserve:publish-aserve-xml-rpc-handler does the same thing but uses the (portable) aserve server framework to handle incoming HTTP requests.

Type Mapping

This XML-RPC implementation for Common Lisp maps types as in the following table. There is a small difference between what types are accepted by the encoder and what types are returned by the decoder.

XML-RPC Type Accepted Comon Lisp Type Returned Common Lisp Type
string string string
int, i4 integer integer
boolean t or nil t or nil
double float float
base64 any array of 1 dimension with at least (unsigned-byte 8) as element type an array of 1 dimension with (unsigned-byte 8) as element type
is08601.dateTime struct xml-rpc-time struct xml-rpc-time
array list or vector list
struct struct xml-rpc-struct struct xml-rpc-struct

Later, generic functions to encode and decode arbitrary CLOS instances could be added.

Base64

The code in the package "S-BASE64" is an implementation of Base64 encoding and decoding (part of RFC 1521). Encoding takes bytes (a binary stream or a byte array) and produces characters (a character stream or a string). Decoding goes the other way.

Release History

  • today: project moved to common-lisp.net
  • release 8, May 9, 2004: added *xml-rpc-authorization* header option (contributed by Nik Gaffney)
  • release 7, March 10, 2004: reorganized code to facilitate porting (added package.lisp and sysdeps.lisp, removed run-xml-rpc-server), integrated contributions from Rudi Schlatte and Brian Mastenbrook; SBCL is now supported; fixed a bug where empty strings were turned into nil, added a test
  • release 6, Januari 21, 2004: ported to LispWorks, added *xml-rpc-package*, *xml-rpc-call-hook* and execute-xml-rpc-call
  • release 5, Januari 20, 2004: added ASDF support, included some contributed patches
  • release 4, June 10, 2003: tracking a minor, but incompatible change in the XML parser
  • release 3, May 25, 2003: the XML parser has been put in a separate package, we are using the more efficient SAX interface of the parser, improved documentation
  • release 2, Januari 6, 2003: we now pass the XML-RPC validator tests, various important bug fixes, improved documentation
  • release 1, December 15, 2002: first public release of working code, not optimized, limited testing

Mailing Lists

CVS version $Id: index.html,v 1.4 2004/07/08 19:36:53 scaekenberghe Exp $

Back to Common-lisp.net.

Valid XHTML 1.0 Strict Valid CSS
roslisp-1.9.20/s-xml-rpc/doc/style.css000066400000000000000000000016551270365674000175600ustar00rootroot00000000000000 .header { font-size: medium; background-color:#336699; color:#ffffff; border-style:solid; border-width: 5px; border-color:#002244; padding: 1mm 1mm 1mm 5mm; } .footer { font-size: small; font-style: italic; text-align: right; background-color:#336699; color:#ffffff; border-style:solid; border-width: 2px; border-color:#002244; padding: 1mm 1mm 1mm 1mm; } .footer a:link { font-weight:bold; color:#ffffff; text-decoration:underline; } .footer a:visited { font-weight:bold; color:#ffffff; text-decoration:underline; } .footer a:hover { font-weight:bold; color:#002244; text-decoration:underline; } .check {font-size: x-small; text-align:right;} .check a:link { font-weight:bold; color:#a0a0ff; text-decoration:underline; } .check a:visited { font-weight:bold; color:#a0a0ff; text-decoration:underline; } .check a:hover { font-weight:bold; color:#000000; text-decoration:underline; } roslisp-1.9.20/s-xml-rpc/s-xml-rpc.asd000066400000000000000000000023641270365674000174520ustar00rootroot00000000000000;;;; -*- Mode: LISP -*- ;;;; ;;;; $Id: s-xml-rpc.asd,v 1.2 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; The S-XML-RPC ASDF system definition ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :asdf) (defsystem :s-xml-rpc :name "S-XML-RPC" :author "Sven Van Caekenberghe " :version "7" :maintainer "Sven Van Caekenberghe , Brian Mastenbrook <>, Rudi Schlatte <>" :licence "Lesser Lisp General Public License (LLGPL)" :description "Common Lisp XML-RPC Package" :long-description "s-xml-rpc is a Common Lisp implementation of the XML-RPC procotol for both client and server" :components ((:module :src :components ((:file "base64") (:file "package" :depends-on ("base64")) (:file "sysdeps" :depends-on ("package")) (:file "xml-rpc" :depends-on ("package" "sysdeps" "base64")) (:file "extensions" :depends-on ("package" "xml-rpc"))))) :depends-on (:s-xml #+sbcl :sb-bsd-sockets)) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/000077500000000000000000000000001270365674000157215ustar00rootroot00000000000000roslisp-1.9.20/s-xml-rpc/src/aserve.lisp000066400000000000000000000051261270365674000201030ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: aserve.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ ;;;; ;;;; This file implements XML-RPC client and server networking based ;;;; on (Portable) AllegroServe (see http://opensource.franz.com/aserve/ ;;;; or http://sourceforge.net/projects/portableaserve/), which you have ;;;; to install first. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defpackage xml-rpc-aserve (:use common-lisp net.aserve.client net.aserve xml-rpc) (:export "XML-RPC-CALL" "START-XML-RPC-ASERVE" "PUBLISH-ASERVE-XML-RPC-HANDLER")) (in-package :xml-rpc-aserve) (defun xml-rpc-call-aserve (encoded &key (url *xml-rpc-url*) (agent *xml-rpc-agent*) (host *xml-rpc-host*) (port *xml-rpc-port*) (basic-autorization *xml-rpc-authorization*) (proxy)) (let ((xml (print-xml-string encoded))) (multiple-value-bind (response response-code headers uri) (do-http-request (format nil "http://~a:~d~a" host port url) :method :post :protocol :http/1.0 :user-agent agent :content-type "text/xml" :basic-authorization basic-autorization :content xml :proxy proxy) (declare (ignore headers uri)) (if (= response-code 200) (let ((result (decode-xml-rpc (make-string-input-stream response)))) (if (typep result 'xml-rpc-fault) (error result) (car result))) (error "http-error:~d" response-code))))) (defun start-xml-rpc-aserve (&key (port *xml-rpc-port*)) (process-run-function "aserve-xml-rpc" #'(lambda () (start :port port :listeners 4 :chunking nil :keep-alive nil)))) (defun publish-aserve-xml-rpc-handler (&key (url *xml-rpc-url*) (agent *xml-rpc-agent*)) (declare (ignore agent)) (publish :path url :content-type "text/xml" :function #'aserve-xml-rpc-handler)) (defun aserve-xml-rpc-handler (request entity) (with-http-response (request entity :response (if (eq :post (request-method request)) *response-ok* *response-bad-request*)) (with-http-body (request entity) (let ((body (get-request-body request)) (id (process-name *current-process*))) (with-input-from-string (in body) (let ((xml (handle-xml-rpc-call in id))) (format-debug t "~d sending ~a~%" id xml) (princ xml *html-stream*))))))) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/base64.lisp000066400000000000000000000124631270365674000177040ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: base64.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of Base64 encoding and decoding. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defpackage s-base64 (:use common-lisp) (:export "DECODE-BASE64" "ENCODE-BASE64" "DECODE-BASE64-BYTES" "ENCODE-BASE64-BYTES") (:documentation "An implementation of standard Base64 encoding and decoding")) (in-package :s-base64) (defparameter +base64-alphabet+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") (defparameter +inverse-base64-alphabet+ (let ((inverse-base64-alphabet (make-array char-code-limit))) (dotimes (i char-code-limit inverse-base64-alphabet) (setf (aref inverse-base64-alphabet i) (position (code-char i) +base64-alphabet+))))) (defun core-encode-base64 (byte1 byte2 byte3) (values (char +base64-alphabet+ (ash byte1 -2)) (char +base64-alphabet+ (logior (ash (logand byte1 #B11) 4) (ash (logand byte2 #B11110000) -4))) (char +base64-alphabet+ (logior (ash (logand byte2 #B00001111) 2) (ash (logand byte3 #B11000000) -6))) (char +base64-alphabet+ (logand byte3 #B111111)))) (defun core-decode-base64 (char1 char2 char3 char4) (let ((v1 (aref +inverse-base64-alphabet+ (char-code char1))) (v2 (aref +inverse-base64-alphabet+ (char-code char2))) (v3 (aref +inverse-base64-alphabet+ (char-code char3))) (v4 (aref +inverse-base64-alphabet+ (char-code char4)))) (values (logior (ash v1 2) (ash v2 -4)) (logior (ash (logand v2 #B1111) 4) (ash v3 -2)) (logior (ash (logand v3 #B11) 6) v4)))) (defun skip-base64-whitespace (stream) (loop (let ((char (peek-char nil stream nil nil))) (cond ((null char) (return nil)) ((null (aref +inverse-base64-alphabet+ (char-code char))) (read-char stream)) (t (return char)))))) (defun decode-base64-bytes (stream) "Decode a base64 encoded character stream, returns a byte array" (let ((out (make-array 256 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0))) (loop (skip-base64-whitespace stream) (let ((in1 (read-char stream nil nil)) (in2 (read-char stream nil nil)) (in3 (read-char stream nil nil)) (in4 (read-char stream nil nil))) (if (null in1) (return)) (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded")) (multiple-value-bind (out1 out2 out3) (core-decode-base64 in1 in2 (if (char= in3 #\=) #\A in3) (if (char= in4 #\=) #\A in4)) (vector-push-extend out1 out) (when (char/= in3 #\=) (vector-push-extend out2 out) (when (char/= in4 #\=) (vector-push-extend out3 out)))))) out)) (defun encode-base64-bytes (array stream &optional (break-lines t)) "Encode a byte array into a base64b encoded character stream" (let ((index 0) (counter 0) (len (length array))) (loop (when (>= index len) (return)) (let ((in1 (aref array index)) (in2 (if (< (+ index 1) len) (aref array (+ index 1)) nil)) (in3 (if (< (+ index 2) len) (aref array (+ index 2)) nil))) (multiple-value-bind (out1 out2 out3 out4) (core-encode-base64 in1 (if (null in2) 0 in2) (if (null in3) 0 in3)) (write-char out1 stream) (write-char out2 stream) (if (null in2) (progn (write-char #\= stream) (write-char #\= stream)) (progn (write-char out3 stream) (if (null in3) (write-char #\= stream) (write-char out4 stream)))) (incf index 3) (incf counter 4) (when (and break-lines (= counter 76)) (terpri stream) (setf counter 0))))))) (defun decode-base64 (in out) "Decode a base64 encoded character input stream into a binary output stream" (loop (skip-base64-whitespace in) (let ((in1 (read-char in nil nil)) (in2 (read-char in nil nil)) (in3 (read-char in nil nil)) (in4 (read-char in nil nil))) (if (null in1) (return)) (if (or (null in2) (null in3) (null in4)) (error "input not aligned/padded")) (multiple-value-bind (out1 out2 out3) (core-decode-base64 in1 in2 (if (char= in3 #\=) #\A in3) (if (char= in4 #\=) #\A in4)) (write-byte out1 out) (when (char/= in3 #\=) (write-byte out2 out) (when (char/= in4 #\=) (write-byte out3 out))))))) (defun encode-base64 (in out &optional (break-lines t)) "Encode a binary input stream into a base64 encoded character output stream" (let ((counter 0)) (loop (let ((in1 (read-byte in nil nil)) (in2 (read-byte in nil nil)) (in3 (read-byte in nil nil))) (if (null in1) (return)) (multiple-value-bind (out1 out2 out3 out4) (core-encode-base64 in1 (if (null in2) 0 in2) (if (null in3) 0 in3)) (write-char out1 out) (write-char out2 out) (if (null in2) (progn (write-char #\= out) (write-char #\= out)) (progn (write-char out3 out) (if (null in3) (write-char #\= out) (write-char out4 out)))) (incf counter 4) (when (and break-lines (= counter 76)) (terpri out) (setf counter 0))))))) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/define-xmlrpc-method.lisp000066400000000000000000000020121270365674000226200ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: define-xmlrpc-method.lisp,v 1.1 2004/07/08 19:45:25 scaekenberghe Exp $ ;;;; ;;;; The code in this file adds a very handly define-xmlrpc-method macro. ;;;; ;;;; (define-xmlrpc-method get-state-name (state) ;;;; :url #u"http://betty.userland.com/RPC2" ;;;; :method "examples.getStateName") ;;;; ;;;; (define-xmlrpc-method get-time () ;;;; :url #u"http://time.xmlrpc.com/RPC2" ;;;; :method "currentTime.getCurrentTime") ;;;; ;;;; It require the PURI package. ;;;; ;;;; Copyright (C) 2004 Frederic Brunel. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defmacro define-xmlrpc-method (name args &key url method) `(defun ,name ,args (xml-rpc-call (encode-xml-rpc-call ,method ,@args) :url ,(puri:uri-path url) :host ,(puri:uri-host url) :port ,(cond ((puri:uri-port url)) (t 80))))) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/extensions.lisp000066400000000000000000000100371270365674000210120ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: extensions.lisp,v 1.1 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; Extensions for xml-rpc: ;;;; ;;;; Server introspection: ;;;; http://xmlrpc.usefulinc.com/doc/reserved.html ;;;; ;;;; Multicall: ;;;; http://www.xmlrpc.com/discuss/msgReader$1208 ;;;; ;;;; Capabilities: ;;;; http://groups.yahoo.com/group/xml-rpc/message/2897 ;;;; ;;;; ;;;; Copyright (C) 2004 Rudi Schlatte ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml-rpc) ;;; Introspection (defun |system.listMethods| () "List the methods that are available on this server." (let ((result nil)) (do-symbols (sym *xml-rpc-package* (sort result #'string-lessp)) (when (and (fboundp sym) (valid-xml-rpc-method-name-p (symbol-name sym))) (push (symbol-name sym) result))))) (defun |system.methodSignature| (method-name) "Dummy system.methodSignature implementation. There's no way to get (and no concept of) required argument types in Lisp, so this function always returns nil or errors." (let ((method (find-xml-rpc-method method-name))) (if method ;; http://xmlrpc.usefulinc.com/doc/sysmethodsig.html says to ;; return a non-array if the signature is not available "n/a" (error "Method ~A not found." method-name)))) (defun |system.methodHelp| (method-name) "Returns the function documentation for the given method." (let ((method (find-xml-rpc-method method-name))) (if method (or (documentation method 'function) "") (error "Method ~A not found." method-name)))) ;;; system.multicall (defun do-one-multicall (call-struct) (let ((name (get-xml-rpc-struct-member call-struct :|methodName|)) (params (get-xml-rpc-struct-member call-struct :|params|))) (handler-bind ((xml-rpc-fault #'(lambda (c) (format-debug (or *xml-rpc-debug-stream* t) "Call to ~A in system.multicall failed with ~a~%" name c) (return-from do-one-multicall (xml-literal (encode-xml-rpc-fault-value (xml-rpc-fault-string c) (xml-rpc-fault-code c)))))) (error #'(lambda (c) (format-debug (or *xml-rpc-debug-stream* t) "Call to ~A in system.multicall failed with ~a~%" name c) (return-from do-one-multicall (xml-literal (encode-xml-rpc-fault-value ;; -32603 ---> server error. internal xml-rpc error (format nil "~a" c) -32603)))))) (format-debug (or *xml-rpc-debug-stream* t) "system.multicall calling ~a with ~s~%" name params) (let ((result (apply *xml-rpc-call-hook* name params))) (list result))))) (defun |system.multicall| (calls) "Implement system.multicall; see http://www.xmlrpc.com/discuss/msgReader$1208 for the specification." (mapcar #'do-one-multicall calls)) ;;; system.getCapabilities (defun |system.getCapabilities| () "Get a list of supported capabilities; see http://groups.yahoo.com/group/xml-rpc/message/2897 for the specification." (let ((capabilities '("xmlrpc" ("specUrl" "http://www.xmlrpc.com/spec" "specVersion" 1) "introspect" ("specUrl" "http://xmlrpc.usefulinc.com/doc/reserved.html" "specVersion" 1) "multicall" ("specUrl" "http://www.xmlrpc.com/discuss/msgReader$1208" "specVersion" 1) "faults_interop" ("specUrl" "http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php" "specVersion" 20010516)))) (apply #'xml-rpc-struct (loop for (name description) on capabilities by #'cddr collecting name collecting (apply #'xml-rpc-struct description))))) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/package.lisp000066400000000000000000000034051270365674000202070ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: package.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; S-XML-RPC package definition ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defpackage s-xml-rpc (:use common-lisp #+ccl ccl #+lispworks mp #+lispworks comm s-xml s-base64) (:export #:xml-rpc-call #:encode-xml-rpc-call #:call-xml-rpc-server #:xml-rpc-condition #:xml-rpc-fault #:xml-rpc-fault-code #:xml-rpc-fault-string #:xml-rpc-error #:xml-rpc-error-place #:xml-rpc-error-data #:start-xml-rpc-server #:xml-rpc-time #:xml-rpc-time-p #:xml-rpc-time-universal-time #:xml-rpc-struct #:xml-rpc-struct-p #:xml-rpc-struct-alist #:get-xml-rpc-struct-member #:xml-rpc-struct-equal #:*xml-rpc-host* #:*xml-rpc-port* #:*xml-rpc-url* #:*xml-rpc-agent* #:*xml-rpc-proxy-host* #:*xml-rpc-proxy-port* #:*xml-rpc-authorization* #:*xml-rpc-debug* #:*xml-rpc-debug-stream* #:*xml-rpc-package* #:*xml-rpc-call-hook* #:execute-xml-rpc-call #:stop-server #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp| #:|system.multicall| #:|system.getCapabilities|) (:documentation "An implementation of the standard XML-RPC protocol for both client and server")) (defpackage s-xml-rpc-exports (:use) (:import-from :s-xml-rpc #:|system.listMethods| #:|system.methodSignature| #:|system.methodHelp| #:|system.multicall| #:|system.getCapabilities|) (:documentation "This package contains the functions callable via xml-rpc.")) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/sysdeps.lisp000066400000000000000000000130421270365674000203040ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: sysdeps.lisp,v 1.1.1.1 2004/06/09 09:02:39 scaekenberghe Exp $ ;;;; ;;;; These are the system dependent part of S-XML-RPC. ;;;; Ports to OpenMCL, LispWorks and SBCL are provided. ;;;; Porting to another CL requires implementating these definitions. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; SBCL port Copyright (C) 2004, Brian Mastenbrook & Rudi Schlatte. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml-rpc) (defmacro with-open-socket-stream ((var host port) &body body) "Execute body with a bidirectional socket stream opened to host:port" #+openmcl `(ccl:with-open-socket (,var :remote-host ,host :remote-port ,port) ,@body) #+lispworks `(with-open-stream (,var (comm:open-tcp-stream ,host ,port)) ,@body) #+sbcl (let ((socket-object (gensym))) `(let ((,socket-object (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp))) (sb-bsd-sockets:socket-connect ,socket-object (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name ,host))) ,port) (let ((,var (sb-bsd-sockets:socket-make-stream ,socket-object :element-type 'character :input t :output t :buffering :none))) (unwind-protect (progn ,@body) (close ,var)))))) (defun run-process (name function &rest arguments) "Create and run a new process with name, executing function on arguments" #+lispworks (apply #'mp:process-run-function name '(:priority 3) function arguments) #+openmcl (apply #'ccl:process-run-function name function arguments) #+sbcl (declare (ignore name)) #+sbcl (apply function arguments)) (defvar *server-processes* nil) (defun start-standard-server (&key port name connection-handler) "Start a server process with name, listening on port, delegating to connection-handler with stream as argument" #+lispworks (progn (comm:start-up-server :function #'(lambda (socket-handle) (let ((client-stream (make-instance 'comm:socket-stream :socket socket-handle :direction :io :element-type 'base-char))) (funcall connection-handler client-stream))) :service port :announce t :error t :wait t :process-name name) name) #+openmcl (progn (ccl:process-run-function name #'(lambda () (let ((server-socket (ccl:make-socket :connect :passive :local-port port :reuse-address t))) (unwind-protect (loop (let ((client-stream (ccl:accept-connection server-socket))) (funcall connection-handler client-stream))) (close server-socket))))) name) #+sbcl (let* ((socket (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)) (handler-fn (lambda (fd) (declare (ignore fd)) (let ((stream (sb-bsd-sockets:socket-make-stream (sb-bsd-sockets:socket-accept socket) :element-type 'character :input t :output t :buffering :none))) (funcall connection-handler stream))))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (sb-bsd-sockets:socket-bind socket #(0 0 0 0) port) (sb-bsd-sockets:socket-listen socket 15) (push (list name socket (sb-sys:add-fd-handler (sb-bsd-sockets:socket-file-descriptor socket) :input handler-fn)) *server-processes*) (values name socket))) (defun stop-server (name) "Kill a server process by name (as started by start-standard-server)" #+lispworks (let ((server-process (mp:find-process-from-name name))) (when server-process (mp:process-kill server-process))) #+openmcl (let ((server-process (find name (ccl:all-processes) :key #'ccl:process-name :test #'string-equal))) (when server-process (ccl:process-kill server-process))) #+sbcl (progn (destructuring-bind (name socket handler) (assoc name *server-processes* :test #'string=) (declare (ignore name)) (sb-sys:remove-fd-handler handler) (sb-bsd-sockets:socket-close socket)) (setf *server-processes* (delete name *server-processes* :key #'car :test #'string=))) name) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/validator1-client.lisp000066400000000000000000000142261270365674000221410ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: validator1-client.lisp,v 1.1 2004/06/14 20:11:55 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC 'validator1' ;;;; server test suite, as live testable from the website ;;;; http://validator.xmlrpc.com and documented on the web page ;;;; http://www.xmlrpc.com/validator1Docs ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml-rpc) (defun random-string (&optional (length 8)) (with-output-to-string (stream) (dotimes (i (random length)) (write-char (code-char (+ 32 (random 95))) stream)))) (defun echo-struct-test () (let* ((struct (xml-rpc-struct :|foo| (random 1000000) :|bar| (random-string) :|fooBar| (list (random 100) (random 100)))) (result (xml-rpc-call (encode-xml-rpc-call :|validator1.echoStructTest| struct)))) (format t "validator1.echoStructTest(~s)=~s~%" struct result) (assert (xml-rpc-struct-equal struct result)))) (defun easy-struct-test () (let* ((moe (random 1000)) (larry (random 1000)) (curry (random 1000)) (struct (xml-rpc-struct :|moe| moe :|larry| larry :|curly| curry)) (result (xml-rpc-call (encode-xml-rpc-call :|validator1.easyStructTest| struct)))) (format t "validator1.easyStructTest(~s)=~s~%" struct result) (assert (= (+ moe larry curry) result)))) (defun count-the-entities () (let* ((string (random-string 512)) (left-angle-brackets (count #\< string)) (right-angle-brackets (count #\> string)) (apostrophes (count #\' string)) (quotes (count #\" string)) (ampersands (count #\& string)) (result (xml-rpc-call (encode-xml-rpc-call :|validator1.countTheEntities| string)))) (format t "validator1.countTheEntitities(~s)=~s~%" string result) (assert (and (xml-rpc-struct-p result) (= left-angle-brackets (get-xml-rpc-struct-member result :|ctLeftAngleBrackets|)) (= right-angle-brackets (get-xml-rpc-struct-member result :|ctRightAngleBrackets|)) (= apostrophes (get-xml-rpc-struct-member result :|ctApostrophes|)) (= quotes (get-xml-rpc-struct-member result :|ctQuotes|)) (= ampersands (get-xml-rpc-struct-member result :|ctAmpersands|)))))) (defun array-of-structs-test () (let ((array (make-array (random 32))) (sum 0)) (dotimes (i (length array)) (setf (aref array i) (xml-rpc-struct :|moe| (random 1000) :|larry| (random 1000) :|curly| (random 1000))) (incf sum (get-xml-rpc-struct-member (aref array i) :|curly|))) (let ((result (xml-rpc-call (encode-xml-rpc-call :|validator1.arrayOfStructsTest| array)))) (format t "validator1.arrayOfStructsTest(~s)=~s~%" array result) (assert (= result sum))))) (defun random-bytes (&optional (length 16)) (let ((bytes (make-array (random length) :element-type '(unsigned-byte 8)))) (dotimes (i (length bytes) bytes) (setf (aref bytes i) (random 256))))) (defun many-types-test () (let* ((integer (random 10000)) (boolean (if (zerop (random 2)) t nil)) (string (random-string)) (double (random 10000.0)) (dateTime (xml-rpc-time)) (base64 (random-bytes)) (result (xml-rpc-call (encode-xml-rpc-call :|validator1.manyTypesTest| integer boolean string double dateTime base64)))) (format t "validator1.manyTypesTest(~s,~s,~s,~s,~s,~s)=~s~%" integer boolean string double dateTime base64 result) (assert (equal integer (elt result 0))) (assert (equal boolean (elt result 1))) (assert (equal string (elt result 2))) (assert (equal double (elt result 3))) (assert (equal (xml-rpc-time-universal-time dateTime) (xml-rpc-time-universal-time (elt result 4)))) (assert (reduce #'(lambda (x y) (and x y)) (map 'list #'= base64 (elt result 5)) :initial-value t)))) (defun simple-struct-return-test () (let* ((number (random 1000)) (result (xml-rpc-call (encode-xml-rpc-call :|validator1.simpleStructReturnTest| number)))) (format t "validator1.simpleStructReturnTest(~s)=~s~%" number result) (assert (and (= (* number 10) (get-xml-rpc-struct-member result :|times10|)) (= (* number 100) (get-xml-rpc-struct-member result :|times100|)) (= (* number 1000) (get-xml-rpc-struct-member result :|times1000|)))))) (defun moderate-size-array-check () (let ((array (make-array (+ 100 (random 100)) :element-type 'string))) (dotimes (i (length array)) (setf (aref array i) (random-string))) (let ((result (xml-rpc-call (encode-xml-rpc-call :|validator1.moderateSizeArrayCheck| array)))) (format t "validator1.moderateSizeArrayCheck(~s)=~s~%" array result) (assert (equal (concatenate 'string (elt array 0) (elt array (1- (length array)))) result))))) (defun nested-struct-test () (let* ((moe (random 1000)) (larry (random 1000)) (curry (random 1000)) (struct (xml-rpc-struct :|moe| moe :|larry| larry :|curly| curry)) (first (xml-rpc-struct :\01 struct)) (april (xml-rpc-struct :\04 first)) (year (xml-rpc-struct :\2000 april)) (result (xml-rpc-call (encode-xml-rpc-call :|validator1.nestedStructTest| year)))) (format t "validator1.nestedStructTest(~s)=~s~%" year result) (assert (= (+ moe larry curry) result)))) (defun test-run (&optional (runs 1)) (dotimes (i runs t) (echo-struct-test) (easy-struct-test) (count-the-entities) (array-of-structs-test) (many-types-test) (simple-struct-return-test) (moderate-size-array-check) (nested-struct-test))) (defun timed-test-run (&optional (runs 1)) (dotimes (i runs t) (time (echo-struct-test)) (time (easy-struct-test)) (time (count-the-entities)) (time (array-of-structs-test)) (time (many-types-test)) (time (simple-struct-return-test)) (time (moderate-size-array-check)) (time (nested-struct-test)))) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/validator1-server.lisp000066400000000000000000000060211270365674000221630ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: validator1-server.lisp,v 1.1 2004/06/14 20:11:55 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC 'validator1' ;;;; server test suite, as live testable from the website ;;;; http://validator.xmlrpc.com and documented on the web page ;;;; http://www.xmlrpc.com/validator1Docs ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml-rpc) (defun |validator1.echoStructTest| (struct) (assert (xml-rpc-struct-p struct)) struct) (defun |validator1.easyStructTest| (struct) (assert (xml-rpc-struct-p struct)) (+ (get-xml-rpc-struct-member struct :|moe|) (get-xml-rpc-struct-member struct :|larry|) (get-xml-rpc-struct-member struct :|curly|))) (defun |validator1.countTheEntities| (string) (assert (stringp string)) (let ((left-angle-brackets (count #\< string)) (right-angle-brackets (count #\> string)) (apostrophes (count #\' string)) (quotes (count #\" string)) (ampersands (count #\& string))) (xml-rpc-struct :|ctLeftAngleBrackets| left-angle-brackets :|ctRightAngleBrackets| right-angle-brackets :|ctApostrophes| apostrophes :|ctQuotes| quotes :|ctAmpersands| ampersands))) (defun |validator1.manyTypesTest| (number boolean string double dateTime base64) (assert (and (integerp number) (or (null boolean) (eq boolean t)) (stringp string) (floatp double) (xml-rpc-time-p dateTime) (and (arrayp base64) (= (array-rank base64) 1) (subtypep (array-element-type base64) '(unsigned-byte 8))))) (list number boolean string double dateTime base64)) (defun |validator1.arrayOfStructsTest| (array) (assert (listp array)) (reduce #'+ (mapcar #'(lambda (struct) (assert (xml-rpc-struct-p struct)) (get-xml-rpc-struct-member struct :|curly|)) array) :initial-value 0)) (defun |validator1.simpleStructReturnTest| (number) (assert (integerp number)) (xml-rpc-struct :|times10| (* number 10) :|times100| (* number 100) :|times1000| (* number 1000))) (defun |validator1.moderateSizeArrayCheck| (array) (assert (listp array)) (concatenate 'string (first array) (first (last array)))) (defun |validator1.nestedStructTest| (struct) (assert (xml-rpc-struct-p struct)) (let* ((year (get-xml-rpc-struct-member struct :\2000)) (april (get-xml-rpc-struct-member year :\04)) (first (get-xml-rpc-struct-member april :\01))) (|validator1.easyStructTest| first))) (import '(|validator1.echoStructTest| |validator1.easyStructTest| |validator1.countTheEntities| |validator1.manyTypesTest| |validator1.arrayOfStructsTest| |validator1.simpleStructReturnTest| |validator1.moderateSizeArrayCheck| |validator1.nestedStructTest|) :s-xml-rpc-exports) ;;;; eof roslisp-1.9.20/s-xml-rpc/src/xml-rpc.lisp000066400000000000000000000600031270365674000201730ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; This is a Common Lisp implementation of the XML-RPC protocol, ;;;; as documented on the website http://www.xmlrpc.com ;;;; This implementation includes both a client and server part. ;;;; A Base64 encoder/decoder and a minimal XML parser are required. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml-rpc) ;;; conditions (define-condition xml-rpc-condition (error) () (:documentation "Parent condition for all conditions thrown by the XML-RPC package")) (define-condition xml-rpc-fault (xml-rpc-condition) ((code :initarg :code :reader xml-rpc-fault-code) (string :initarg :string :reader xml-rpc-fault-string)) (:report (lambda (condition stream) (format stream "XML-RPC fault with message '~a' and code ~d." (xml-rpc-fault-string condition) (xml-rpc-fault-code condition)))) (:documentation "This condition is thrown when the XML-RPC server returns a fault")) (setf (documentation 'xml-rpc-fault-code 'function) "Get the code from an XML-RPC fault") (setf (documentation 'xml-rpc-fault-string 'function) "Get the string from an XML-RPC fault") (define-condition xml-rpc-error (xml-rpc-condition) ((place :initarg :code :reader xml-rpc-error-place) (data :initarg :data :reader xml-rpc-error-data)) (:report (lambda (condition stream) (format stream "XML-RPC error ~a at ~a." (xml-rpc-error-data condition) (xml-rpc-error-place condition)))) (:documentation "This condition is thrown when an XML-RPC protocol error occurs")) (setf (documentation 'xml-rpc-error-place 'function) "Get the place from an XML-RPC error" (documentation 'xml-rpc-error-data 'function) "Get the data from an XML-RPC error") ;;; iso8601 support (the xml-rpc variant) (defun universal-time->iso8601 (time &optional (stream nil)) "Convert a Common Lisp universal time to a string in the XML-RPC variant of ISO8601" (multiple-value-bind (second minute hour date month year) (decode-universal-time time) (format stream "~d~2,'0d~2,'0dT~2,'0d:~2,'0d:~2,'0d" year month date hour minute second))) (defun iso8601->universal-time (string) "Convert string in the XML-RPC variant of ISO8601 to a Common Lisp universal time" (let (year month date (hour 0) (minute 0) (second 0)) (when (< (length string) 9) (error "~s is to short to represent an iso8601" string)) (setf year (parse-integer string :start 0 :end 4) month (parse-integer string :start 4 :end 6) date (parse-integer string :start 6 :end 8)) (when (and (>= (length string) 17) (char= #\T (char string 8))) (setf hour (parse-integer string :start 9 :end 11) minute (parse-integer string :start 12 :end 14) second (parse-integer string :start 15 :end 17))) (encode-universal-time second minute hour date month year))) (defstruct (xml-rpc-time (:print-function print-xml-rpc-time)) "A wrapper around a Common Lisp universal time to be interpreted as an XML-RPC-TIME" universal-time) (setf (documentation 'xml-rpc-time-p 'function) "Return T when the argument is an XML-RPC time" (documentation 'xml-rpc-time-universal-time 'function) "Return the universal time from an XML-RPC time") (defun print-xml-rpc-time (xml-rpc-time stream depth) (declare (ignore depth)) (format stream "#" (universal-time->iso8601 (xml-rpc-time-universal-time xml-rpc-time)))) (defun xml-rpc-time (&optional (universal-time (get-universal-time))) "Create a new XML-RPC-TIME struct with the universal time specified, defaulting to now" (make-xml-rpc-time :universal-time universal-time)) ;;; a wrapper for literal strings, where escaping #\< and #\& is not ;;; desired (defstruct (xml-literal (:print-function print-xml-literal)) "A wrapper around a Common Lisp string that will be sent over the wire unescaped" content) (setf (documentation 'xml-literal-p 'function) "Return T when the argument is an unescaped xml string" (documentation 'xml-literal-content 'function) "Return the content of a literal xml string") (defun print-xml-literal (xml-literal stream depth) (declare (ignore depth)) (format stream "#" (xml-literal-content xml-literal))) (defun xml-literal (content) "Create a new XML-LITERAL struct with the specified content." (make-xml-literal :content content)) ;;; an extra datatype for xml-rpc structures (associative maps) (defstruct (xml-rpc-struct (:print-function print-xml-rpc-struct)) "An XML-RPC-STRUCT is an associative map of member names and values" alist) (setf (documentation 'xml-rpc-struct-p 'function) "Return T when the argument is an XML-RPC struct" (documentation 'xml-rpc-struct-alist 'function) "Return the alist of member names and values from an XML-RPC struct") (defun print-xml-rpc-struct (xml-element stream depth) (declare (ignore depth)) (format stream "#" (xml-rpc-struct-alist xml-element))) (defun get-xml-rpc-struct-member (struct member) "Get the value of a specific member of an XML-RPC-STRUCT" (cdr (assoc member (xml-rpc-struct-alist struct)))) (defun (setf get-xml-rpc-struct-member) (value struct member) "Set the value of a specific member of an XML-RPC-STRUCT" (let ((pair (assoc member (xml-rpc-struct-alist struct)))) (if pair (rplacd pair value) (push (cons member value) (xml-rpc-struct-alist struct))) value)) (defun xml-rpc-struct (&rest args) "Create a new XML-RPC-STRUCT from the arguments: alternating member names and values" (unless (evenp (length args)) (error "~s must contain an even number of elements" args)) (let (alist) (loop (if (null args) (return) (push (cons (pop args) (pop args)) alist))) (make-xml-rpc-struct :alist alist))) (defun xml-rpc-struct-equal (struct1 struct2) "Compare two XML-RPC-STRUCTs for equality" (if (and (xml-rpc-struct-p struct1) (xml-rpc-struct-p struct2) (= (length (xml-rpc-struct-alist struct1)) (length (xml-rpc-struct-alist struct2)))) (dolist (assoc (xml-rpc-struct-alist struct1) t) (unless (equal (get-xml-rpc-struct-member struct2 (car assoc)) (cdr assoc)) (return-from xml-rpc-struct-equal nil))) nil)) ;;; encoding support (defun encode-xml-rpc-struct (struct stream) (princ "" stream) (dolist (member (xml-rpc-struct-alist struct)) (princ "" stream) (format stream "~a" (car member)) ; assuming name contains no special characters (encode-xml-rpc-value (cdr member) stream) (princ "" stream)) (princ "" stream)) (defun encode-xml-rpc-array (sequence stream) (princ "" stream) (map 'nil #'(lambda (element) (encode-xml-rpc-value element stream)) sequence) (princ "" stream)) (defun encode-xml-rpc-value (arg stream) (princ "" stream) (cond ((integerp arg) (format stream "~d" arg)) ((floatp arg) (format stream "~f" arg)) ((or (null arg) (eq arg t)) (princ "" stream) (princ (if arg 1 0) stream) (princ "" stream)) ((or (stringp arg) (symbolp arg)) (princ "" stream) (print-string-xml (string arg) stream) (princ "" stream)) ((and (arrayp arg) (= (array-rank arg) 1) (subtypep (array-element-type arg) '(unsigned-byte 8))) (princ "" stream) (encode-base64-bytes arg stream) (princ "" stream)) ((xml-rpc-time-p arg) (princ "" stream) (universal-time->iso8601 (xml-rpc-time-universal-time arg) stream) (princ "" stream)) ((xml-literal-p arg) (princ (xml-literal-content arg) stream)) ((or (listp arg) (vectorp arg)) (encode-xml-rpc-array arg stream)) ((xml-rpc-struct-p arg) (encode-xml-rpc-struct arg stream)) ;; add generic method call (t (error "cannot encode ~s" arg))) (princ "" stream)) (defun encode-xml-rpc-args (args stream) (princ "" stream) (dolist (arg args) (princ "" stream) (encode-xml-rpc-value arg stream) (princ "" stream)) (princ "" stream)) (defun encode-xml-rpc-call (name &rest args) "Encode an XML-RPC call with name and args as an XML string" (with-output-to-string (stream) (princ "" stream) ;; Spec says: The string may only contain identifier characters, ;; upper and lower-case A-Z, the numeric characters, 0-9, ;; underscore, dot, colon and slash. (format stream "~a" (string name)) ; assuming name contains no special characters (when args (encode-xml-rpc-args args stream)) (princ "" stream))) (defun encode-xml-rpc-result (value) (with-output-to-string (stream) (princ "" stream) (encode-xml-rpc-args (list value) stream) (princ "" stream))) (defun encode-xml-rpc-fault-value (fault-string &optional (fault-code 0)) ;; for system.multicall (with-output-to-string (stream) (princ "" stream) (format stream "faultCode~d" fault-code) (princ "faultString" stream) (print-string-xml fault-string stream) (princ "" stream) (princ "" stream))) (defun encode-xml-rpc-fault (fault-string &optional (fault-code 0)) (with-output-to-string (stream) (princ "" stream) (princ (encode-xml-rpc-fault-value fault-string fault-code) stream) (princ "" stream))) ;;; decoding support (defun decode-xml-rpc-new-element (name attributes seed) (declare (ignore seed name attributes)) '()) (defun decode-xml-rpc-finish-element (name attributes parent-seed seed) (declare (ignore attributes)) (cons (case name ((:|int| :|i4|) (parse-integer seed)) (:|double| (read-from-string seed)) (:|boolean| (= 1 (parse-integer seed))) (:|string| (if (null seed) "" seed)) (:|dateTime.iso8601| (xml-rpc-time (iso8601->universal-time seed))) (:|base64| (if (null seed) (make-array 0 :element-type '(unsigned-byte 8)) (with-input-from-string (in seed) (decode-base64-bytes in)))) (:|array| (car seed)) (:|data| (nreverse seed)) (:|value| (if (stringp seed) seed (car seed))) (:|struct| (make-xml-rpc-struct :alist seed)) (:|member| (cons (cadr seed) (car seed))) (:|name| (intern seed :keyword)) (:|params| (nreverse seed)) (:|param| (car seed)) (:|fault| (make-condition 'xml-rpc-fault :string (get-xml-rpc-struct-member (car seed) :|faultString|) :code (get-xml-rpc-struct-member (car seed) :|faultCode|))) (:|methodName| seed) (:|methodCall| (let ((pair (nreverse seed))) (cons (car pair) (cadr pair)))) (:|methodResponse| (car seed))) parent-seed)) (defun decode-xml-rpc-text (string seed) (declare (ignore seed)) string) (defun decode-xml-rpc (stream) (car (start-parse-xml stream (make-instance 'xml-parser-state :new-element-hook #'decode-xml-rpc-new-element :finish-element-hook #'decode-xml-rpc-finish-element :text-hook #'decode-xml-rpc-text)))) ;;; networking basics (defparameter *xml-rpc-host* "localhost" "String naming the default XML-RPC host to use") (defparameter *xml-rpc-port* 80 "Integer specifying the default XML-RPC port to use") (defparameter *xml-rpc-url* "/RPC2" "String specifying the default XML-RPC URL to use") (defparameter *xml-rpc-agent* (concatenate 'string (lisp-implementation-type) " " (lisp-implementation-version)) "String specifying the default XML-RPC agent to include in server responses") (defvar *xml-rpc-debug* nil "When T the XML-RPC client and server part will be more verbose about their protocol") (defvar *xml-rpc-debug-stream* nil "When not nil it specifies where debugging output should be written to") (defparameter *xml-rpc-proxy-host* nil "When not null, a string naming the XML-RPC proxy host to use") (defparameter *xml-rpc-proxy-port* nil "When not null, an integer specifying the XML-RPC proxy port to use") (defparameter *xml-rpc-package* (find-package :s-xml-rpc-exports) "Package for XML-RPC callable functions") (defparameter *xml-rpc-authorization* nil "When not null, a string to be used as Authorization header") (defun format-debug (&rest args) (when *xml-rpc-debug* (apply #'format args))) (defparameter +crlf+ (make-array 2 :element-type 'character :initial-contents '(#\return #\linefeed))) (defun tokens (string &key (start 0) (separators (list #\space #\return #\linefeed #\tab))) (if (= start (length string)) '() (let ((p (position-if #'(lambda (char) (find char separators)) string :start start))) (if p (if (= p start) (tokens string :start (1+ start) :separators separators) (cons (subseq string start p) (tokens string :start (1+ p) :separators separators))) (list (subseq string start)))))) (defun format-header (stream headers) (mapc #'(lambda (header) (cond ((null (rest header)) (write-string (first header) stream) (princ +crlf+ stream)) ((second header) (apply #'format stream header) (princ +crlf+ stream)))) headers) (princ +crlf+ stream)) (defun debug-stream (in) ;; Uggh, this interacts badly with SLIME, so turning it off for now... - BMM #| (if *xml-rpc-debug* (make-echo-stream in *standard-output*) in)) |# in) ;;; client API (defun xml-rpc-call (encoded &key (url *xml-rpc-url*) (agent *xml-rpc-agent*) (host *xml-rpc-host*) (port *xml-rpc-port*) (authorization *xml-rpc-authorization*) (proxy-host *xml-rpc-proxy-host*) (proxy-port *xml-rpc-proxy-port*)) "Execute an already encoded XML-RPC call and return the decoded result" (let ((uri (if proxy-host (format nil "http://~a:~d~a" host port url) url))) (with-open-socket-stream (connection (if proxy-host proxy-host host) (if proxy-port proxy-port port)) (format-debug (or *xml-rpc-debug-stream* t) "POST ~a HTTP/1.0~%Host: ~a:~d~%" uri host port) (format-header connection `(("POST ~a HTTP/1.0" ,uri) ("User-Agent: ~a" ,agent) ("Host: ~a:~d" ,host ,port) ("Authorization: ~a" ,authorization) ("Content-Type: text/xml") ("Content-Length: ~d" ,(length encoded)))) (princ encoded connection) (finish-output connection) (format-debug (or *xml-rpc-debug-stream* t) "Sending ~a~%~%" encoded) (let ((header (read-line connection nil nil))) (when (null header) (error "no response from server")) (format-debug (or *xml-rpc-debug-stream* t) "~a~%" header) (setf header (tokens header)) (unless (and (>= (length header) 3) (string-equal (second header) "200") (string-equal (third header) "OK")) (error "http-error:~{ ~a~}" header))) (do ((line (read-line connection nil nil) (read-line connection nil nil))) ((or (null line) (= 1 (length line)))) (format-debug (or *xml-rpc-debug-stream* t) "~a~%" line)) (let ((result (decode-xml-rpc (debug-stream connection)))) (if (typep result 'xml-rpc-fault) (error result) (car result)))))) (defun call-xml-rpc-server (server-keywords name &rest args) "Encode and execute an XML-RPC call with name and args, using the list of server-keywords" (apply #'xml-rpc-call (cons (apply #'encode-xml-rpc-call (cons name args)) server-keywords))) (defun describe-server (&key (host *xml-rpc-host*) (port *xml-rpc-port*) (url *xml-rpc-url*)) "Tries to describe a remote server using system.* methods" (dolist (method (xml-rpc-call (encode-xml-rpc-call "system.listMethods") :host host :port port :url url)) (format t "Method ~a ~a~%~a~%~%" method (xml-rpc-call (encode-xml-rpc-call "system.methodSignature" method) :host host :port port :url url) (xml-rpc-call (encode-xml-rpc-call "system.methodHelp" method) :host host :port port :url url)))) ;;; server API (defvar *xml-rpc-call-hook* 'execute-xml-rpc-call "A function to execute the xml-rpc call and return the result, accepting a method-name string and a optional argument list") (defparameter +xml-rpc-method-characters+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.:/") (defun valid-xml-rpc-method-name-p (method-name) (not (find-if-not (lambda (c) (find c +xml-rpc-method-characters+)) method-name))) (defun find-xml-rpc-method (method-name) "Looks for a method with the given name in *xml-rpc-package*, except that colons in the name get converted to hyphens." (let ((sym (find-symbol method-name *xml-rpc-package*))) (if (fboundp sym) sym nil))) (defun execute-xml-rpc-call (method-name &rest arguments) "Execute method METHOD-NAME on ARGUMENTS, or raise an error if no such method exists in *XML-RPC-PACKAGE*" (let ((method (find-xml-rpc-method method-name))) (if method (apply method arguments) ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php ;; -32601 ---> server error. requested method not found (error 'xml-rpc-fault :code -32601 :string (format nil "Method ~A not found." method-name))))) (defun handle-xml-rpc-call (in id) "Handle an actual call, reading XML from in and returning the XML-encoded result." ;; Try to conform to ;; http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php (handler-bind ((s-xml:xml-parser-error #'(lambda (c) (format-debug (or *xml-rpc-debug-stream* t) "~a request parsing failed with ~a~%" id c) (return-from handle-xml-rpc-call ;; -32700 ---> parse error. not well formed (encode-xml-rpc-fault (format nil "~a" c) -32700)))) (xml-rpc-fault #'(lambda (c) (format-debug (or *xml-rpc-debug-stream* t) "~a call failed with ~a~%" id c) (return-from handle-xml-rpc-call (encode-xml-rpc-fault (xml-rpc-fault-string c) (xml-rpc-fault-code c))))) (error #'(lambda (c) (format-debug (or *xml-rpc-debug-stream* t) "~a call failed with ~a~%" id c) (return-from handle-xml-rpc-call ;; -32603 ---> server error. internal xml-rpc error (encode-xml-rpc-fault (format nil "~a" c) -32603))))) (let ((call (decode-xml-rpc (debug-stream in)))) (format-debug (or *xml-rpc-debug-stream* t) "~a received call ~s~%" id call) (let ((result (apply *xml-rpc-call-hook* (first call) (rest call)))) (format-debug (or *xml-rpc-debug-stream* t) "~a call result is ~s~%" id result) (encode-xml-rpc-result result))))) (defun xml-rpc-implementation-version () "Identify ourselves" (concatenate 'string "$Id: xml-rpc.lisp,v 1.4 2004/06/17 19:43:11 rschlatte Exp $" " " (lisp-implementation-type) " " (lisp-implementation-version))) (defun xml-rpc-server-connection-handler (connection id agent url) "Handle an incoming connection, doing both all HTTP and XML-RPC stuff" (handler-bind ((error #'(lambda (c) (format-debug (or *xml-rpc-debug-stream* t) "xml-rpc server connection handler failed with ~a~%" c) (error c)))) (let* ((header (read-line connection nil nil)) ;; (header-string header) ) (when (null header) (error "no request from client")) (setf header (tokens header)) (unless (and (>= (length header) 3) (string-equal (first header) "POST") (string-equal (second header) url)) ;; (warn "Header ~a looks malformed, but proceeding - temporary fix BMM" header-string) #|(progn (format-header connection `(("HTTP/1.0 400 Bad Request") ("Server: ~a" ,agent) ("Connection: close"))) (format-debug (or *xml-rpc-debug-stream* t) "~d got a bad request ~a~%" id header))|# ) ;; Originally this was only done if the header looked ok (progn (do ((line (read-line connection nil nil) (read-line connection nil nil))) ((or (null line) (= 1 (length line)))) (format-debug (or *xml-rpc-debug-stream* t) "~d ~a~%" id line)) (let ((xml (handle-xml-rpc-call connection id))) (format-header connection `(("HTTP/1.0 200 OK") ("Server: ~a" ,agent) ("Connection: close") ("Content-Type: text/xml") ("Content-Length: ~d" ,(length xml)))) (princ xml connection) (format-debug (or *xml-rpc-debug-stream* t) "~d sending ~a~%" id xml)))) (force-output connection) (close connection))) (defparameter *counter* 0 "Unique ID for incoming connections") (defun start-xml-rpc-server (&key (port *xml-rpc-port*) (url *xml-rpc-url*) (agent *xml-rpc-agent*)) "Start an XML-RPC server in a separate process" (start-standard-server :name (format nil "xml-rpc server ~a:~d" url port) :port port :connection-handler #'(lambda (client-stream) (let ((id (incf *counter*))) (format-debug (or *xml-rpc-debug-stream* t) "spawned connection handler ~d~%" id) (run-process (format nil "xml-rpc-server-connection-handler-~d" id) #'xml-rpc-server-connection-handler client-stream id agent url))))) ;;;; eof roslisp-1.9.20/s-xml-rpc/test/000077500000000000000000000000001270365674000161115ustar00rootroot00000000000000roslisp-1.9.20/s-xml-rpc/test/all-tests.lisp000066400000000000000000000012251270365674000207120ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: all-tests.lisp,v 1.2 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; Load and execute all unit and functional tests ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (load (merge-pathnames "test-base64" *load-pathname*) :verbose t) (load (merge-pathnames "test-xml-rpc" *load-pathname*) :verbose t) (load (merge-pathnames "test-extensions" *load-pathname*) :verbose t) ;;;; eof roslisp-1.9.20/s-xml-rpc/test/test-base64.lisp000066400000000000000000000073071270365674000210520ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: test-base64.lisp,v 1.1.1.1 2004/06/09 09:02:41 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for base64.lisp ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-base64) (assert (equal (multiple-value-list (core-encode-base64 0 0 0)) (list #\A #\A #\A #\A))) (assert (equal (multiple-value-list (core-encode-base64 255 255 255)) (list #\/ #\/ #\/ #\/))) (assert (equal (multiple-value-list (core-encode-base64 1 2 3)) (list #\A #\Q #\I #\D))) (assert (equal (multiple-value-list (core-encode-base64 10 20 30)) (list #\C #\h #\Q #\e))) (assert (equal (multiple-value-list (core-decode-base64 #\A #\A #\A #\A)) (list 0 0 0))) (assert (equal (multiple-value-list (core-decode-base64 #\/ #\/ #\/ #\/)) (list 255 255 255))) (assert (equal (multiple-value-list (core-decode-base64 #\A #\Q #\I #\D)) (list 1 2 3))) (assert (equal (multiple-value-list (core-decode-base64 #\C #\h #\Q #\e)) (list 10 20 30))) (assert (let* ((string "Hello World!") (bytes (map 'vector #'char-code string)) encoded decoded) (setf encoded (with-output-to-string (out) (encode-base64-bytes bytes out))) (setf decoded (with-input-from-string (in encoded) (decode-base64-bytes in))) (equal string (map 'string #'code-char decoded)))) ;;; this is more of a functional test (defun same-character-file (file1 file2) (with-open-file (a file1 :direction :input) (with-open-file (b file2 :direction :input) (loop (let ((char-a (read-char a nil nil nil)) (char-b (read-char b nil nil nil))) (cond ((not (or (and (null char-a) (null char-b)) (and char-a char-b))) (return-from same-character-file nil)) ((null char-a) (return-from same-character-file t)) ((char/= char-a char-b) (return-from same-character-file nil)))))))) (defun same-binary-file (file1 file2) (with-open-file (a file1 :direction :input :element-type 'unsigned-byte) (with-open-file (b file2 :direction :input :element-type 'unsigned-byte) (loop (let ((byte-a (read-byte a nil nil)) (byte-b (read-byte b nil nil))) (cond ((not (or (and (null byte-a) (null byte-b)) (and byte-a byte-b))) (return-from same-binary-file nil)) ((null byte-a) (return-from same-binary-file t)) ((/= byte-a byte-b) (return-from same-binary-file nil)))))))) (let ((original (merge-pathnames "test.b64" *load-pathname*)) (first-gif (merge-pathnames "test.gif" *load-pathname*)) (b64 (merge-pathnames "test2.b64" *load-pathname*)) (second-gif (merge-pathnames "test2.gif" *load-pathname*))) (with-open-file (in original :direction :input) (with-open-file (out first-gif :direction :output :element-type 'unsigned-byte :if-does-not-exist :create :if-exists :supersede) (decode-base64 in out))) (with-open-file (in first-gif :direction :input :element-type 'unsigned-byte) (with-open-file (out b64 :direction :output :if-does-not-exist :create :if-exists :supersede) (encode-base64 in out nil))) (assert (same-character-file original b64)) (with-open-file (in b64 :direction :input) (with-open-file (out second-gif :direction :output :element-type 'unsigned-byte :if-does-not-exist :create :if-exists :supersede) (decode-base64 in out))) (assert (same-binary-file first-gif second-gif)) (delete-file first-gif) (delete-file b64) (delete-file second-gif)) ;;;; eofroslisp-1.9.20/s-xml-rpc/test/test-extensions.lisp000066400000000000000000000041031270365674000221540ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: test-extensions.lisp,v 1.1 2004/06/17 19:43:11 rschlatte Exp $ ;;;; ;;;; Unit and functional tests for xml-rpc.lisp ;;;; ;;;; Copyright (C) 2004 Rudi Schlatte ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml-rpc) (let* ((server-port 8080) (server-process-name (start-xml-rpc-server :port server-port)) (server-args `(:port ,server-port)) (*xml-rpc-package* (make-package (gensym))) (symbols '(|system.listMethods| |system.methodSignature| |system.methodHelp| |system.multicall| |system.getCapabilities|))) (import symbols *xml-rpc-package*) (sleep 1) ; give the server some time to come up ;-) (unwind-protect (progn (assert (equal (sort (call-xml-rpc-server server-args "system.listMethods") #'string<) (sort (mapcar #'string symbols) #'string<))) (assert (every #'string= (mapcar (lambda (name) (call-xml-rpc-server server-args "system.methodHelp" name)) symbols) (mapcar (lambda (name) (or (documentation name 'function) "")) symbols))) (assert (= 2 (length (call-xml-rpc-server server-args "system.multicall" (list (xml-rpc-struct "methodName" "system.listMethods") (xml-rpc-struct "methodName" "system.methodHelp" "params" (list "system.multicall")))))))) (stop-server server-process-name) (delete-package *xml-rpc-package*))) ;;;; eofroslisp-1.9.20/s-xml-rpc/test/test-xml-rpc.lisp000066400000000000000000000042041270365674000213410ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: test-xml-rpc.lisp,v 1.1.1.1 2004/06/09 09:02:41 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for xml-rpc.lisp ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml-rpc) (assert (let ((now (get-universal-time))) (equal (iso8601->universal-time (universal-time->iso8601 now)) now))) (assert (equal (with-input-from-string (in (encode-xml-rpc-call "add" 1 2)) (decode-xml-rpc in)) '("add" 1 2))) (assert (equal (with-input-from-string (in (encode-xml-rpc-result '(1 2))) (car (decode-xml-rpc in))) '(1 2))) (let ((condition (with-input-from-string (in (encode-xml-rpc-fault "Fatal Error" 100)) (decode-xml-rpc in)))) (assert (typep condition 'xml-rpc-fault)) (assert (equal (xml-rpc-fault-string condition) "Fatal Error")) (assert (equal (xml-rpc-fault-code condition) 100))) (assert (xml-rpc-time-p (xml-rpc-call (encode-xml-rpc-call "currentTime.getCurrentTime") :host "time.xmlrpc.com"))) (assert (equal (xml-rpc-call (encode-xml-rpc-call "examples.getStateName" 41) :host "betty.userland.com") "South Dakota")) (assert (equal (call-xml-rpc-server '(:host "betty.userland.com") "examples.getStateName" 41) "South Dakota")) (assert (let ((server-process-name (start-xml-rpc-server :port 8080))) (sleep 1) ; give the server some time to come up ;-) (unwind-protect (equal (xml-rpc-call (encode-xml-rpc-call "XML-RPC-IMPLEMENTATION-VERSION") :port 8080) (xml-rpc-implementation-version)) (stop-server server-process-name)))) (assert (let* ((struct-in (xml-rpc-struct :foo 100 :bar "")) (xml (with-output-to-string (out) (encode-xml-rpc-value struct-in out))) (struct-out (with-input-from-string (in xml) (decode-xml-rpc in)))) (xml-rpc-struct-equal struct-in struct-out))) ;;;; eofroslisp-1.9.20/s-xml-rpc/test/test.b64000077500000000000000000000037141270365674000174150ustar00rootroot00000000000000R0lGODlhNABYAMQAAP////vi5etreuM0SN8ZL+dOYPCIk+56hPi/xPGapPjP1N4EGvHr9PSstMzI6riw4IY+kHsie3lvyVtMu0Y4tN3b8Y+CzX1ast2ftskNNNBdfqGb2so0WeHL4E8spLA0aiH5BAAAAAAALAAAAAA0AFgAQAX/ICCOZGmeaKqeBUEc5WAATbECQnCfyiAWsFIBgfMJFoTOYcAQERYN0SK4KxEUp4FPC/ABXN/oKOCtmh0OxGPj+UAgHmKhIZiZHJLJhMKXNKsMFQAMFnp6EogWFxEWOAsCgw4VfyN5IhKNABMPZhAUe3yhoYiYFmsWiISYlCoMeaJ8ehR5hoektLCjEhCcJGgQqSkKC1BmxscBxEQkBAlOxSMDCzY/ZQAICyPEOwnbCgXgcyQCBeQFWCIHVDXhJN/hkMc0DR0iA80oPXbyI+Vd6CO+RdOxjAWVYz367bPXzciVHjKwGCAwg4AOfiUOEBgg4ICAe08WYCFgQ0aKBtaM/xWSEMuQKA+1WHrIhYpCJgB4KDzYA4BPFQejLAgdSvSB0QoOHgCT4GAEKqSfUuT8ZIHVCAYbWOaaQErSiqoYw4oVkWxBwRETt41RW2KBNWluq5QteCAbiQJxSRATQIDVRisLnJmQ5sLi2MNhP24cUIDxRcRjCAsG0HgHnbEaFRAwAURExxsJHh8jB2CJiQZBOALokHIEgXiqjQks3frcFyRdcKfzonGBaGMDxFzTIgDBMBd4GVN7sQSdAWpiuZQIsJHkCwNQqKOgCBmF2wZu5xj4XUL4MUJcMTlowmANhAgXhGoIIMA5NUKwQIWCcANNIkEMMPDBAWgUmAEGIgwDQ/97u2ByCQVNTdCIBRTssEEfVpUWjwgMpIHKTQCg0oQnguhhBgObPCBBLys4gIoEJVTA0gSCGIPUegBolV8tomwSVgUTiEBhehZsgMB6AZ4Q4JJLcjhIh1ntAeMITamw0ycSbDDJHx0aRdSLuPSIyQM1rnAEMcRc0R0/c7EADUppLgRAAoRtuE0ABvBF3lpmlTCMI9A5shkz1vB1G0AqtNkPEoWx9cwMGllRWEitmTCMSAlCw4ymAFxaz6KWOuqmnGuWaqqpHQTw6almbmSAAqoG8M0AB3XXA0mC/bWCbYjxNQ0JdHY6WQoJZDgaYymhJEICgaKQg1hXgDMYOuKooMD/hvJQx4BmlsYT7GyWGoZRcJRhm44z3HaaFzOD4mXeDglRVitlWMjgghYgJaCZuE8gWkW86ZJgxCOA0iBtp1royk8Zmi1UGAAT4WmSZwREYUClZhzQ7MX3MDqFri4kIK7BY12cxRW+4dNCuSaQNpYW74KHhALgbXawpQP4ixGzWoiD3UZ9HkAqCUKfysA9zx1AJznvrlkBmCuu10AGCFSgDg5Y0CFaIbLAAuIJF86CyAZGbWDKAxwcoEACFbzhgZEWwHEBV0H5oSNLX5eAipSkcDWBB3MjsocHeUhwwQdEoFgmABX4ZCJLrSylCwQfoFHB5RpwIAJ4BehIwQY49tTI/wMVArDTDu1JKRSL2GBBXdMkFNIE5JpMeQOKNYl9i+CFk9KLJIQ0gUpTURmTR+67J5/IA2iQQEhOthvjgH5crT7UUrZsMMIDNa04Vt9i75Ee+KNUiRF6sTDFIfU8toTIWUqm0PgmE5i/QpLyXGh/Ja/4AQHUsciFAGExEzGBhUOIMEF7JDfAUMykgFv5RB/CZ4sHGAsFeABFTJSXvCKFjlUgnA5cMBbCUPXpBBtCQB3yNCwa1OFqIkAADK5lgAOsygQdUMYJiPGWX5mgLo/BRmACooIcnpAZvjLPE2rVjVUxoGKiSoER4beysrQFU2TBohNgUBcSkmCK7piCAS62LlR12QUAC1hIC8aIHU6hAIzaGNYThtWNzbwGWGc04w0uVRAwhDGPufFhplqYnBUIMQB4WiKiREYMG2pjUJ0607A60MaJneBnJayCbjK5HR5y8pNiCQEAOw==roslisp-1.9.20/s-xml/000077500000000000000000000000001270365674000143505ustar00rootroot00000000000000roslisp-1.9.20/s-xml/ChangeLog000066400000000000000000000041631270365674000161260ustar00rootroot000000000000002005-11-20 Sven Van Caekenberghe * added xml prefix namespace as per REC-xml-names-19990114 (by Rudi Schlatte) 2005-11-06 Sven Van Caekenberghe * removed Debian packaging directory (on Luca's request) * added CDATA support (patch contributed by Peter Van Eynde pvaneynd@mailworks.org) 2005-08-30 Sven Van Caekenberghe * added Debian packaging directory (contributed by Luca Capello luca@pca.it) * added experimental XML namespace support 2005-02-03 Sven Van Caekenberghe * release 5 (cvs tag RELEASE_5) * added :start and :end keywords to print-string-xml * fixed a bug: in a tag containing whitespace, like the parser collapsed and ingnored all whitespace and considered the tag to be empty! this is now fixed and a unit test has been added * cleaned up xml character escaping a bit: single quotes and all normal whitespace (newline, return and tab) is preserved a unit test for this has been added * IE doesn't understand the ' XML entity, so I've commented that out for now. Also, using actual newlines for newlines is probably better than using #xA, which won't get any end of line conversion by the server or user agent. June 2004 Sven Van Caekenberghe * release 4 * project moved to common-lisp.net, renamed to s-xml, * added examples counter, tracer and remove-markup, improved documentation 13 Jan 2004 Sven Van Caekenberghe * release 3 * added ASDF systems * optimized print-string-xml 10 Jun 2003 Sven Van Caekenberghe * release 2 * added echo-xml function: we are no longer taking the car when the last seed is returned from start-parse-xml 25 May 2003 Sven Van Caekenberghe * release 1 * first public release of working code * tested on OpenMCL * rewritten to be event-based, to improve efficiency and to optionally use different DOM representations * more documentation end of 2002 Sven Van Caekenberghe * release 0 * as part of an XML-RPC implementation $Id: ChangeLog,v 1.5 2005/11/20 14:24:33 scaekenberghe Exp $ roslisp-1.9.20/s-xml/Makefile000066400000000000000000000021011270365674000160020ustar00rootroot00000000000000# $Id: Makefile,v 1.3 2004/07/08 19:31:22 scaekenberghe Exp $ default: @echo Possible targets: @echo clean-openmcl --- remove all '*.dfsl' recursively @echo clean-lw --- remove all '*.nfasl' recursively @echo clean-emacs --- remove all '*~' recursively @echo clean --- all of the above clean-openmcl: find . -name "*.dfsl" | xargs rm clean-lw: find . -name "*.nfasl" | xargs rm clean-emacs: find . -name "*~" | xargs rm clean: clean-openmcl clean-lw clean-emacs # # This can obviously only be done by a specific person in a very specific context ;-) # PRJ=s-xml ACCOUNT=scaekenberghe CVSRT=:ext:$(ACCOUNT)@common-lisp.net:/project/$(PRJ)/cvsroot release: rm -rf /tmp/$(PRJ) /tmp/public_html /tmp/$(PRJ).tgz /tmp/$(PRJ).tgz.asc cd /tmp; cvs -d$(CVSRT) export -r HEAD $(PRJ); cvs -d$(CVSRT) export -r HEAD public_html mv /tmp/public_html /tmp/$(PRJ)/doc cd /tmp; gnutar cvfz $(PRJ).tgz $(PRJ); gpg -a -b $(PRJ).tgz scp /tmp/$(PRJ).tgz $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html scp /tmp/$(PRJ).tgz.asc $(ACCOUNT)@common-lisp.net:/project/$(PRJ)/public_html roslisp-1.9.20/s-xml/doc/000077500000000000000000000000001270365674000151155ustar00rootroot00000000000000roslisp-1.9.20/s-xml/doc/S-XML.html000066400000000000000000000156471270365674000166600ustar00rootroot00000000000000S-XML

API for package S-XML

A simple XML parser with an efficient, purely functional, event-based interface as well as a DOM interface

(echo-xml in out)   function

Parse a toplevel XML element from stream in, echoing and pretty printing the result to stream out

(first-xml-element-child xml-element)   function

Get the first child of an xml-element

(get-entities xml-parser-state)   generic-function

Get the entities hashtable of an XML parser state

(setf (get-entities xml-parser-state) value)   generic-function

Set the entities hashtable of an XML parser state

(get-finish-element-hook xml-parser-state)   generic-function

Get the finish element hook of an XML parser state

(setf (get-finish-element-hook xml-parser-state) value)   generic-function

Set the finish element hook of an XML parser state

(get-new-element-hook xml-parser-state)   generic-function

Get the new element hook of an XML parser state

(setf (get-new-element-hook xml-parser-state) value)   generic-function

Set the new element hook of an XML parser state

(get-seed xml-parser-state)   generic-function

Get the initial user seed of an XML parser state

(setf (get-seed xml-parser-state) value)   generic-function

Set the initial user seed of an XML parser state

(get-text-hook xml-parser-state)   generic-function

Get the text hook of an XML parser state

(setf (get-text-hook xml-parser-state) value)   generic-function

Set the text hook of an XML parser state

(make-xml-element &key name attributes children)   function

Make and return a new xml-element struct

(new-xml-element name &rest children)   function

Make a new xml-element with name and children

(parse-xml stream &key (output-type :lxml))   function

Parse a character stream as XML and generate a DOM of output-type, defaulting to :lxml

(parse-xml-dom stream output-type)   generic-function

Parse a character stream as XML and generate a DOM of output-type

(parse-xml-file filename &key (output-type :lxml))   function

Parse a character file as XML and generate a DOM of output-type, defaulting to :lxml

(parse-xml-string string &key (output-type :lxml))   function

Parse a string as XML and generate a DOM of output-type, defaulting to :lxml

(print-string-xml string stream)   function

Write the characters of string to stream using basic XML conventions

(print-xml dom &key (stream t) pretty (input-type :lxml) (header))   function

Generate XML output on a character stream (t by default) from a DOM of input-type (:lxml by default), optionally pretty printing (off by default), or adding a header (none by default)

(print-xml-dom dom input-type stream pretty level)   generic-function

Generate XML output on a character stream from a DOM of input-type, optionally pretty printing using level

(print-xml-string dom &key pretty (input-type :lxml))   function

Generate XML output to a string from a DOM of input-type (:lxml by default), optionally pretty printing (off by default)

(start-parse-xml stream &optional (state (make-instance (quote xml-parser-state))))   function

Parse and return a toplevel XML element from stream, using parser state

(xml-element-attribute xml-element key)   function

Return the string value of the attribute with name the keyword :key of xml-element if any, return null if not found

(setf (xml-element-attribute xml-element key) value)   function

Set the string value of the attribute with name the keyword :key of xml-element, creating a new attribute if necessary or overwriting an existing one, returning the value

(xml-element-attributes object)   function

Return the alist of attribute names and values dotted pairs from an xml-element struct

(xml-element-children object)   function

Return the list of children from an xml-element struct

(xml-element-name object)   function

Return the name from an xml-element struct

(xml-element-p object)   function

Return T when the argument is an xml-element struct

xml-parser-error   condition

Thrown by the XML parser to indicate errorneous input
Class precedence list: xml-parser-error error serious-condition condition standard-object t
Class init args: :stream :args :message

(xml-parser-error-args xml-parser-error)   generic-function

Get the error arguments from an XML parser error

(xml-parser-error-message xml-parser-error)   generic-function

Get the message from an XML parser error

(xml-parser-error-stream xml-parser-error)   generic-function

Get the stream from an XML parser error

xml-parser-state   class

The XML parser state passed along all code making up the parser
Class precedence list: xml-parser-state standard-object t
Class init args: :text-hook :finish-element-hook :new-element-hook :seed :entities

Documentation generated by lispdoc running on LispWorks

 roslisp-1.9.20/s-xml/doc/index.html000066400000000000000000000375421270365674000171250ustar00rootroot00000000000000 S-XML

S-XML

S-XML is a simple XML parser implemented in Common Lisp. Originally it was written by Sven Van Caekenberghe. It is now being maintained by Sven Van Caekenberghe, Rudi Schlatte and Brian Mastenbrook. S-XML is used by S-XML-RPC and CL-PREVALENCE.

This XML parser implementation has the following features:

  • It works (handling many common XML usages).
  • It is very small (the core is about 400 lines of code, including comments and whitespace).
  • It has a core API that is simple, efficient and pure functional, much like that from SSAX (see also http://ssax.sourceforge.net).
  • It supports different DOM models: an XSML-based one, an LXML-based one and a classic xml-element struct based one.
  • It is reasonably time and space efficient (internally avoiding garbage generatation as much as possible).

This XML parser implementation has the following limitations:

  • It does not support CDATA.
  • Only supports simple character sets.
  • It does not support name spaces
  • It does not support any special tags (like processing instructions).
  • It is not validating, even skips DTD's all together.

Download

You can download the LLGPL source code and documentation as s-xml.tgz (signature: s-xml.tgz.asc for which the public key can be found in the common-lisp.net keyring) (build and/or install with ASDF).

You can view the CVS Repository or get anonymous CVS access as follows: 

$ cvs -d:pserver:anonymous@common-lisp.net:/project/s-xml/cvsroot login
(Logging in to anonymous@common-lisp.net)
CVS password: anonymous
$ cvs -d:pserver:anonymous@common-lisp.net:/project/s-xml/cvsroot co s-xml

API

The plain API exported by the package S-XML (automatically generated by LispDoc) is available in S-XML.html.

XML Parser

Using a DOM parser is easier, but usually less efficient: see the next sections. To use the event-based API of the parser, you call the function start-parse-xml on a stream, specifying 3 hook functions:

  • new-element-hook (name attributes seed) => seed
    Called when the parser enters a new element. The name of the element (tag) and the attributes (an unordered dotted pair list of attribute names as keywords and attribute values as strings) of the element are passed in, as well as the seed from the previous element (either the last encountered sibling or the parent). The hook must return a seed value to be passed to the first child element or directly to finish-element-hook (when there are no children).
  • finish-element-hook (name attributes parent-seed seed) => seed
    Called when the parser leaves an element. The name of the element (tag) and the attributes (an unordered dotted pair list of attribute names as keywords and attribute values as strings) of the element are passed in, as well as the parent-seed, the seed passed to us when this element started, i.e. passed to our corresponding new-element-hook, as well as the seed from the previous element (either the last encountered sibling or the parent). The hook must return the final seed value for this element to be passed to the next sibling or to the parent (when there are no more children).
  • text-hook (string seed) => seed
    Called when the parser finds text as contents. The string of the text encountered is passed in, as well as the seed from the previous element (either the last encountered sibling or the parent). The hook must return the final seed value for this element to be passed to the next sibling or to the parent (when there are no more children).

As an example, consider the following tracer that shows how the different hooks are called: 

(defun trace-xml-new-element-hook (name attributes seed)
  (let ((new-seed (cons (1+ (car seed)) (1+ (cdr seed)))))
    (trace-xml-log (car seed) 
                   "(new-element :name ~s :attributes ~:[()~;~:*~s~] :seed ~s) => ~s" 
                   name attributes seed new-seed)
    new-seed))

(defun trace-xml-finish-element-hook (name attributes parent-seed seed)
  (let ((new-seed (cons (1- (car seed)) (1+ (cdr seed)))))
    (trace-xml-log (car parent-seed)
                   "(finish-element :name ~s :attributes ~:[()~;~:*~s~] :parent-seed ~s :seed ~s) => ~s" 
                   name attributes parent-seed seed new-seed)
    new-seed))

(defun trace-xml-text-hook (string seed)
  (let ((new-seed (cons (car seed) (1+ (cdr seed)))))
    (trace-xml-log (car seed) 
                   "(text :string ~s :seed ~s) => ~s" 
                   string seed new-seed)
    new-seed))

(defun trace-xml (in)
  "Parse and trace a toplevel XML element from stream in"
  (start-parse-xml in
		   (make-instance 'xml-parser-state
				  :seed (cons 0 0) 
                                  ;; seed car is xml element nesting level
                                  ;; seed cdr is ever increasing from element to element
				  :new-element-hook #'trace-xml-new-element-hook
                                  :finish-element-hook #'trace-xml-finish-element-hook
				  :text-hook #'trace-xml-text-hook)))

This is the output of the tracer on two small XML documents, the seed is a CONS that keeps track of the nesting level in its CAR and of its flow through the hooks with an ever increasing number is its CDR: 

S-XML 31 > (with-input-from-string (in "<FOO X='10' Y='20'><P>Text</P><BAR/><H1><H2></H2></H1></FOO>") (trace-xml in))
(new-element :name :FOO :attributes ((:Y . "20") (:X . "10")) :seed (0 . 0)) => (1 . 1)
  (new-element :name :P :attributes () :seed (1 . 1)) => (2 . 2)
    (text :string "Text" :seed (2 . 2)) => (2 . 3)
  (finish-element :name :P :attributes () :parent-seed (1 . 1) :seed (2 . 3)) => (1 . 4)
  (new-element :name :BAR :attributes () :seed (1 . 4)) => (2 . 5)
  (finish-element :name :BAR :attributes () :parent-seed (1 . 4) :seed (2 . 5)) => (1 . 6)
  (new-element :name :H1 :attributes () :seed (1 . 6)) => (2 . 7)
    (new-element :name :H2 :attributes () :seed (2 . 7)) => (3 . 8)
    (finish-element :name :H2 :attributes () :parent-seed (2 . 7) :seed (3 . 8)) => (2 . 9)
  (finish-element :name :H1 :attributes () :parent-seed (1 . 6) :seed (2 . 9)) => (1 . 10)
(finish-element :name :FOO :attributes ((:Y . "20") (:X . "10")) :parent-seed (0 . 0) :seed (1 . 10)) => (0 . 11)
(0 . 11)

S-XML 32 > (with-input-from-string (in "<FOO><UL><LI>1</LI><LI>2</LI><LI>3</LI></UL></FOO>") (trace-xml in))
(new-element :name :FOO :attributes () :seed (0 . 0)) => (1 . 1)
  (new-element :name :UL :attributes () :seed (1 . 1)) => (2 . 2)
    (new-element :name :LI :attributes () :seed (2 . 2)) => (3 . 3)
      (text :string "1" :seed (3 . 3)) => (3 . 4)
    (finish-element :name :LI :attributes () :parent-seed (2 . 2) :seed (3 . 4)) => (2 . 5)
    (new-element :name :LI :attributes () :seed (2 . 5)) => (3 . 6)
      (text :string "2" :seed (3 . 6)) => (3 . 7)
    (finish-element :name :LI :attributes () :parent-seed (2 . 5) :seed (3 . 7)) => (2 . 8)
    (new-element :name :LI :attributes () :seed (2 . 8)) => (3 . 9)
      (text :string "3" :seed (3 . 9)) => (3 . 10)
    (finish-element :name :LI :attributes () :parent-seed (2 . 8) :seed (3 . 10)) => (2 . 11)
  (finish-element :name :UL :attributes () :parent-seed (1 . 1) :seed (2 . 11)) => (1 . 12)
(finish-element :name :FOO :attributes () :parent-seed (0 . 0) :seed (1 . 12)) => (0 . 13)
(0 . 13)

The following example counts tags, attributes and characters: 

(defclass count-xml-seed ()
  ((elements :initform 0)
   (attributes :initform 0)
   (characters :initform 0)))

(defun count-xml-new-element-hook (name attributes seed)
  (declare (ignore name))
  (incf (slot-value seed 'elements))
  (incf (slot-value seed 'attributes) (length attributes))
  seed)

(defun count-xml-text-hook (string seed)
  (incf (slot-value seed 'characters) (length string))
  seed)
  
(defun count-xml (in)
  "Parse a toplevel XML element from stream in, counting elements, attributes and characters"
  (start-parse-xml in
		   (make-instance 'xml-parser-state
				  :seed (make-instance 'count-xml-seed)
				  :new-element-hook #'count-xml-new-element-hook
				  :text-hook #'count-xml-text-hook)))

(defun count-xml-file (pathname)
  "Parse XMl from the file at pathname, counting elements, attributes and characters"
  (with-open-file (in pathname)
    (let ((result (count-xml in)))
      (with-slots (elements attributes characters) result
        (format t 
  "~a contains ~d XML elements, ~d attributes and ~d characters.~%"
                pathname elements attributes characters)))))

This example removes XML markup: 

(defun remove-xml-markup (in)
  (let* ((state (make-instance 'xml-parser-state
                              :text-hook #'(lambda (string seed) (cons string seed))))
         (result (start-parse-xml in state)))
    (apply #'concatenate 'string (nreverse result))))

The next example is from the xml-element struct DOM implementation, where the SSAX parser hook functions are building the actual DOM: 

(defun standard-new-element-hook (name attributes seed)
  (declare (ignore name attributes seed))
  '())

(defun standard-finish-element-hook (name attributes parent-seed seed)
  (let ((xml-element (make-xml-element :name name
				       :attributes attributes
				       :children (nreverse seed))))
    (cons xml-element parent-seed)))

(defun standard-text-hook (string seed)
  (cons string seed))

(defmethod parse-xml-dom (stream (output-type (eql :xml-struct)))
  (car (start-parse-xml stream
			(make-instance 'xml-parser-state
				       :new-element-hook #'standard-new-element-hook
				       :finish-element-hook #'standard-finish-element-hook
				       :text-hook #'standard-text-hook))))

The parse state can be used to specify the initial seed value (nil by default), and the set of known entities (the 5 standard entities (lt, gt, amp, qout, apos) and nbps by default).

DOM

Using a DOM parser is easier, but usually less efficient. Currently three different DOM's are supported:

  • The DOM type :sxml is an XSML-based one
  • The DOM type :lxml is an LXML-based one
  • The DOM type :xml-struct is a classic xml-element struct based one

There is a generic API that is identical for each type of DOM, with an extra parameter input-type or output-type used to specify the type of DOM. The default DOM type is :lxml. Here are some examples: 

? (in-package :s-xml)
#<Package "S-XML">

? (setf xml-string "<foo id='top'><bar>text</bar></foo>")
"<foo id='top'><bar>text</bar></foo>"

? (parse-xml-string xml-string)
((:|foo| :|id| "top") (:|bar| "text"))

? (parse-xml-string xml-string :output-type :sxml)
(:|foo| (:@ (:|id| "top")) (:|bar| "text"))

? (parse-xml-string xml-string :output-type :xml-struct)
#S(XML-ELEMENT :NAME :|foo| :ATTRIBUTES ((:|id| . "top"))
               :CHILDREN (#S(XML-ELEMENT :NAME :|bar|
                                         :ATTRIBUTES NIL
                                         :CHILDREN ("text"))))

? (print-xml * :pretty t :input-type :xml-struct)
<foo id="top">
  <bar>text</bar>
</foo>
NIL

? (print-xml '(p "Interesting stuff at " ((a href "http://slashdot.org") "SlashDot")))
<P>Interesting stuff at <A HREF="http://slashdot.org">SlashDot</A></P>
NIL

Tag and attribute names are converted to keywords. Note that XML is case-sensitive, hence the fact that Common Lisp has to resort to the special literal symbol syntax.

Release History and ChangeLog

2005-02-03 Sven Van Caekenberghe <svc@mac.com>

        * release 5 (cvs tag RELEASE_5)
	* added :start and :end keywords to print-string-xml
	* fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser collapsed 
	  and ingnored all whitespace and considered the tag to be empty!
          this is now fixed and a unit test has been added
	* cleaned up xml character escaping a bit: single quotes and all normal whitespace  
	  (newline, return and tab) is preserved a unit test for this has been added
	* IE doesn't understand the ' XML entity, so I've commented that out for now. 
	  Also, using actual newlines for newlines is probably better than using #xA, 
	  which won't get any end of line conversion by the server or user agent.

June 2004 Sven Van Caekenberghe <svc@mac.com>

	* release 4
	* project moved to common-lisp.net, renamed to s-xml, 
	* added examples counter, tracer and remove-markup, improved documentation

13 Jan 2004 Sven Van Caekenberghe <svc@mac.com>
	
	* release 3
	* added ASDF systems
	* optimized print-string-xml

10 Jun 2003 Sven Van Caekenberghe <svc@mac.com>
	
	* release 2
	* added echo-xml function: we are no longer taking the car when
	  the last seed is returned from start-parse-xml

25 May 2003 Sven Van Caekenberghe <svc@mac.com>
	
	* release 1
	* first public release of working code
	* tested on OpenMCL
	* rewritten to be event-based, to improve efficiency and 
	  to optionally use different DOM representations
	* more documentation

end of 2002 Sven Van Caekenberghe <svc@mac.com>
	
	* release 0
	* as part of an XML-RPC implementation

Todo

  • Some should find some time to add CDATA support (both in the parser and as a print function) - this shouldn't be too hard, and it would be really useful!

Mailing Lists

CVS version $Id: index.html,v 1.10 2005/02/03 08:36:05 scaekenberghe Exp $

Back to Common-lisp.net.

Valid XHTML 1.0 Strict Valid CSS
roslisp-1.9.20/s-xml/doc/style.css000066400000000000000000000016551270365674000167760ustar00rootroot00000000000000 .header { font-size: medium; background-color:#336699; color:#ffffff; border-style:solid; border-width: 5px; border-color:#002244; padding: 1mm 1mm 1mm 5mm; } .footer { font-size: small; font-style: italic; text-align: right; background-color:#336699; color:#ffffff; border-style:solid; border-width: 2px; border-color:#002244; padding: 1mm 1mm 1mm 1mm; } .footer a:link { font-weight:bold; color:#ffffff; text-decoration:underline; } .footer a:visited { font-weight:bold; color:#ffffff; text-decoration:underline; } .footer a:hover { font-weight:bold; color:#002244; text-decoration:underline; } .check {font-size: x-small; text-align:right;} .check a:link { font-weight:bold; color:#a0a0ff; text-decoration:underline; } .check a:visited { font-weight:bold; color:#a0a0ff; text-decoration:underline; } .check a:hover { font-weight:bold; color:#000000; text-decoration:underline; } roslisp-1.9.20/s-xml/s-xml.asd000066400000000000000000000023261270365674000161040ustar00rootroot00000000000000;;;; -*- Mode: LISP -*- ;;;; ;;;; $Id: s-xml.asd,v 1.2 2005/12/14 21:49:04 scaekenberghe Exp $ ;;;; ;;;; The S-XML ASDF system definition ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :asdf) (defsystem :s-xml :name "S-XML" :author "Sven Van Caekenberghe " :version "3" :maintainer "Sven Van Caekenberghe , Brian Mastenbrook <>, Rudi Schlatte <>" :licence "Lisp Lesser General Public License (LLGPL)" :description "Simple Common Lisp XML Parser" :long-description "S-XML is a Common Lisp implementation of a simple XML parser, with a SAX-like and DOM interface" :components ((:module :src :components ((:file "package") (:file "xml" :depends-on ("package")) (:file "dom" :depends-on ("package" "xml")) (:file "lxml-dom" :depends-on ("dom")) (:file "sxml-dom" :depends-on ("dom")) (:file "xml-struct-dom" :depends-on ("dom")))))) ;;;; eof roslisp-1.9.20/s-xml/src/000077500000000000000000000000001270365674000151375ustar00rootroot00000000000000roslisp-1.9.20/s-xml/src/dom.lisp000066400000000000000000000055201270365674000166110ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: dom.lisp,v 1.2 2005/08/29 15:01:47 scaekenberghe Exp $ ;;;; ;;;; This is the generic simple DOM parser and printer interface. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) ;;; top level DOM parser interface (defgeneric parse-xml-dom (stream output-type) (:documentation "Parse a character stream as XML and generate a DOM of output-type")) (defun parse-xml (stream &key (output-type :lxml)) "Parse a character stream as XML and generate a DOM of output-type, defaulting to :lxml" (parse-xml-dom stream output-type)) (defun parse-xml-string (string &key (output-type :lxml)) "Parse a string as XML and generate a DOM of output-type, defaulting to :lxml" (with-input-from-string (stream string) (parse-xml-dom stream output-type))) (defun parse-xml-file (filename &key (output-type :lxml)) "Parse a character file as XML and generate a DOM of output-type, defaulting to :lxml" (with-open-file (in filename :direction :input) (parse-xml-dom in output-type))) ;;; top level DOM printer interface (defgeneric print-xml-dom (dom input-type stream pretty level) (:documentation "Generate XML output on a character stream from a DOM of input-type, optionally pretty printing using level")) (defun print-xml (dom &key (stream t) (pretty nil) (input-type :lxml) (header)) "Generate XML output on a character stream (t by default) from a DOM of input-type (:lxml by default), optionally pretty printing (off by default), or adding a header (none by default)" (when header (format stream header)) (when pretty (terpri stream)) (print-xml-dom dom input-type stream pretty 1)) (defun print-xml-string (dom &key (pretty nil) (input-type :lxml)) "Generate XML output to a string from a DOM of input-type (:lxml by default), optionally pretty printing (off by default)" (with-output-to-string (stream) (print-xml dom :stream stream :pretty pretty :input-type input-type))) ;;; shared/common support functions (defun print-spaces (n stream &optional (preceding-newline t)) (when preceding-newline (terpri stream)) (loop :repeat n :do (write-char #\Space stream))) (defun print-solitary-tag (tag stream) (write-char #\< stream) (print-identifier tag stream) (write-string "/>" stream)) (defun print-closing-tag (tag stream) (write-string " stream)) (defun print-attribute (name value stream) (write-char #\space stream) (print-identifier name stream t) (write-string "=\"" stream) (print-string-xml value stream) (write-char #\" stream)) ;;;; eof roslisp-1.9.20/s-xml/src/lxml-dom.lisp000066400000000000000000000061451270365674000175670ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: lxml-dom.lisp,v 1.6 2005/11/20 14:34:15 scaekenberghe Exp $ ;;;; ;;;; LXML implementation of the generic DOM parser and printer. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) ;;; the lxml hooks to generate lxml (defun lxml-new-element-hook (name attributes seed) (declare (ignore name attributes seed)) '()) (defun lxml-finish-element-hook (name attributes parent-seed seed) (let ((xml-element (cond ((and (null seed) (null attributes)) name) (attributes `((,name ,@(let (list) (dolist (attribute attributes list) (push (cdr attribute) list) (push (car attribute) list)))) ,@(nreverse seed))) (t `(,name ,@(nreverse seed)))))) (cons xml-element parent-seed))) (defun lxml-text-hook (string seed) (cons string seed)) ;;; standard DOM interfaces (defmethod parse-xml-dom (stream (output-type (eql :lxml))) (car (start-parse-xml stream (make-instance 'xml-parser-state :new-element-hook #'lxml-new-element-hook :finish-element-hook #'lxml-finish-element-hook :text-hook #'lxml-text-hook)))) (defun plist->alist (plist) (when plist (cons (cons (first plist) (second plist)) (plist->alist (rest (rest plist)))))) (defmethod print-xml-dom (dom (input-type (eql :lxml)) stream pretty level) (declare (special *namespaces*)) (cond ((symbolp dom) (print-solitary-tag dom stream)) ((stringp dom) (print-string-xml dom stream)) ((consp dom) (let (tag attributes) (cond ((symbolp (first dom)) (setf tag (first dom))) ((consp (first dom)) (setf tag (first (first dom)) attributes (plist->alist (rest (first dom))))) (t (error "Input not recognized as LXML ~s" dom))) (let ((*namespaces* (extend-namespaces attributes *namespaces*))) (write-char #\< stream) (print-identifier tag stream) (loop :for (name . value) :in attributes :do (print-attribute name value stream)) (if (rest dom) (let ((children (rest dom))) (write-char #\> stream) (if (and (= (length children) 1) (stringp (first children))) (print-string-xml (first children) stream) (progn (dolist (child children) (when pretty (print-spaces (* 2 level) stream)) (if (stringp child) (print-string-xml child stream) (print-xml-dom child input-type stream pretty (1+ level)))) (when pretty (print-spaces (* 2 (1- level)) stream)))) (print-closing-tag tag stream)) (write-string "/>" stream))))) (t (error "Input not recognized as LXML ~s" dom)))) ;;;; eofroslisp-1.9.20/s-xml/src/package.lisp000066400000000000000000000036321270365674000174270ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: package.lisp,v 1.6 2005/11/20 14:24:34 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of a very basic XML parser. ;;;; The parser is non-validating. ;;;; The API into the parser is pure functional parser hook model that comes from SSAX, ;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net ;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. ;;;; ;;;; Copyright (C) 2002, 2003, 2004, 2005 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defpackage s-xml (:use common-lisp) (:export ;; main parser interface #:start-parse-xml #:print-string-xml #:xml-parser-error #:xml-parser-error-message #:xml-parser-error-args #:xml-parser-error-stream #:xml-parser-state #:get-entities #:get-seed #:get-new-element-hook #:get-finish-element-hook #:get-text-hook ;; dom parser and printer #:parse-xml-dom #:parse-xml #:parse-xml-string #:parse-xml-file #:print-xml-dom #:print-xml #:print-xml-string ;; xml-element structure #:make-xml-element #:xml-element-children #:xml-element-name #:xml-element-attribute #:xml-element-attributes #:xml-element-p #:new-xml-element #:first-xml-element-child ;; namespaces #:*ignore-namespaces* #:*local-namespace* #:*namespaces* #:*require-existing-symbols* #:*auto-export-symbols* #:*auto-create-namespace-packages* #:find-namespace #:register-namespace #:get-prefix #:get-uri #:get-package #:resolve-identifier #:extend-namespaces #:print-identifier #:split-identifier) (:documentation "A simple XML parser with an efficient, purely functional, event-based interface as well as a DOM interface")) ;;;; eof roslisp-1.9.20/s-xml/src/sxml-dom.lisp000066400000000000000000000057051270365674000175770ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: sxml-dom.lisp,v 1.5 2005/11/20 14:34:15 scaekenberghe Exp $ ;;;; ;;;; LXML implementation of the generic DOM parser and printer. ;;;; ;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) ;;; the sxml hooks to generate sxml (defun sxml-new-element-hook (name attributes seed) (declare (ignore name attributes seed)) '()) (defun sxml-finish-element-hook (name attributes parent-seed seed) (let ((xml-element (append (list name) (when attributes (list (let (list) (dolist (attribute attributes (cons :@ list)) (push (list (car attribute) (cdr attribute)) list))))) (nreverse seed)))) (cons xml-element parent-seed))) (defun sxml-text-hook (string seed) (cons string seed)) ;;; the standard DOM interfaces (defmethod parse-xml-dom (stream (output-type (eql :sxml))) (car (start-parse-xml stream (make-instance 'xml-parser-state :new-element-hook #'sxml-new-element-hook :finish-element-hook #'sxml-finish-element-hook :text-hook #'sxml-text-hook)))) (defmethod print-xml-dom (dom (input-type (eql :sxml)) stream pretty level) (declare (special *namespaces*)) (cond ((stringp dom) (print-string-xml dom stream)) ((consp dom) (let ((tag (first dom)) attributes children) (if (and (consp (second dom)) (eq (first (second dom)) :@)) (setf attributes (rest (second dom)) children (rest (rest dom))) (setf children (rest dom))) (let ((*namespaces* (extend-namespaces (loop :for (name value) :in attributes :collect (cons name value)) *namespaces*))) (write-char #\< stream) (print-identifier tag stream) (loop :for (name value) :in attributes :do (print-attribute name value stream)) (if children (progn (write-char #\> stream) (if (and (= (length children) 1) (stringp (first children))) (print-string-xml (first children) stream) (progn (dolist (child children) (when pretty (print-spaces (* 2 level) stream)) (if (stringp child) (print-string-xml child stream) (print-xml-dom child input-type stream pretty (1+ level)))) (when pretty (print-spaces (* 2 (1- level)) stream)))) (print-closing-tag tag stream)) (write-string "/>" stream))))) (t (error "Input not recognized as SXML ~s" dom)))) ;;;; eof roslisp-1.9.20/s-xml/src/xml-struct-dom.lisp000066400000000000000000000115721270365674000207350ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: xml-struct-dom.lisp,v 1.3 2005/09/20 09:57:48 scaekenberghe Exp $ ;;;; ;;;; XML-STRUCT implementation of the generic DOM parser and printer. ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) ;;; xml-element struct datastructure and API (defstruct xml-element name ; :tag-name attributes ; a assoc list of (:attribute-name . "attribute-value") children ; a list of children/content either text strings or xml-elements ) (setf (documentation 'xml-element-p 'function) "Return T when the argument is an xml-element struct" (documentation 'xml-element-attributes 'function) "Return the alist of attribute names and values dotted pairs from an xml-element struct" (documentation 'xml-element-children 'function) "Return the list of children from an xml-element struct" (documentation 'xml-element-name 'function) "Return the name from an xml-element struct" (documentation 'make-xml-element 'function) "Make and return a new xml-element struct") (defun xml-element-attribute (xml-element key) "Return the string value of the attribute with name the keyword :key of xml-element if any, return null if not found" (let ((pair (assoc key (xml-element-attributes xml-element) :test #'eq))) (when pair (cdr pair)))) (defun (setf xml-element-attribute) (value xml-element key) "Set the string value of the attribute with name the keyword :key of xml-element, creating a new attribute if necessary or overwriting an existing one, returning the value" (let ((attributes (xml-element-attributes xml-element))) (if (null attributes) (push (cons key value) (xml-element-attributes xml-element)) (let ((pair (assoc key attributes :test #'eq))) (if pair (setf (cdr pair) value) (push (cons key value) (xml-element-attributes xml-element))))) value)) (defun new-xml-element (name &rest children) "Make a new xml-element with name and children" (make-xml-element :name name :children children)) (defun first-xml-element-child (xml-element) "Get the first child of an xml-element" (first (xml-element-children xml-element))) (defun xml-equal (xml-1 xml-2) (and (xml-element-p xml-1) (xml-element-p xml-2) (eq (xml-element-name xml-1) (xml-element-name xml-2)) (equal (xml-element-attributes xml-1) (xml-element-attributes xml-2)) (reduce #'(lambda (&optional (x t) (y t)) (and x y)) (mapcar #'(lambda (x y) (or (and (stringp x) (stringp y) (string= x y)) (xml-equal x y))) (xml-element-children xml-1) (xml-element-children xml-2))))) ;;; printing xml structures (defmethod print-xml-dom (xml-element (input-type (eql :xml-struct)) stream pretty level) (declare (special *namespaces*)) (let ((*namespaces* (extend-namespaces (xml-element-attributes xml-element) *namespaces*))) (write-char #\< stream) (print-identifier (xml-element-name xml-element) stream) (loop :for (name . value) :in (xml-element-attributes xml-element) :do (print-attribute name value stream)) (let ((children (xml-element-children xml-element))) (if children (progn (write-char #\> stream) (if (and (= (length children) 1) (stringp (first children))) (print-string-xml (first children) stream) (progn (dolist (child children) (when pretty (print-spaces (* 2 level) stream)) (if (stringp child) (print-string-xml child stream) (print-xml-dom child input-type stream pretty (1+ level)))) (when pretty (print-spaces (* 2 (1- level)) stream)))) (print-closing-tag (xml-element-name xml-element) stream)) (write-string "/>" stream))))) ;;; the standard hooks to generate xml-element structs (defun standard-new-element-hook (name attributes seed) (declare (ignore name attributes seed)) '()) (defun standard-finish-element-hook (name attributes parent-seed seed) (let ((xml-element (make-xml-element :name name :attributes attributes :children (nreverse seed)))) (cons xml-element parent-seed))) (defun standard-text-hook (string seed) (cons string seed)) ;;; top level standard parser interfaces (defmethod parse-xml-dom (stream (output-type (eql :xml-struct))) (car (start-parse-xml stream (make-instance 'xml-parser-state :new-element-hook #'standard-new-element-hook :finish-element-hook #'standard-finish-element-hook :text-hook #'standard-text-hook)))) ;;;; eof roslisp-1.9.20/s-xml/src/xml.lisp000066400000000000000000000703651270365674000166430ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: xml.lisp,v 1.14 2005/11/20 14:24:34 scaekenberghe Exp $ ;;;; ;;;; This is a Common Lisp implementation of a basic but usable XML parser. ;;;; The parser is non-validating and not complete (no CDATA). ;;;; Namespace and entities are handled. ;;;; The API into the parser is a pure functional parser hook model that comes from SSAX, ;;;; see also http://pobox.com/~oleg/ftp/Scheme/xml.html or http://ssax.sourceforge.net ;;;; Different DOM models are provided, an XSML, an LXML and a xml-element struct based one. ;;;; ;;;; Copyright (C) 2002, 2003, 2004, 2005 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) ;;; error reporting (define-condition xml-parser-error (error) ((message :initarg :message :reader xml-parser-error-message) (args :initarg :args :reader xml-parser-error-args) (stream :initarg :stream :reader xml-parser-error-stream :initform nil)) (:report (lambda (condition stream) (format stream "XML parser ~?~@[ near stream position ~d~]." (xml-parser-error-message condition) (xml-parser-error-args condition) (and (xml-parser-error-stream condition) (file-position (xml-parser-error-stream condition)))))) (:documentation "Thrown by the XML parser to indicate errorneous input")) (setf (documentation 'xml-parser-error-message 'function) "Get the message from an XML parser error" (documentation 'xml-parser-error-args 'function) "Get the error arguments from an XML parser error" (documentation 'xml-parser-error-stream 'function) "Get the stream from an XML parser error") (defun parser-error (message &optional args stream) (make-condition 'xml-parser-error :message message :args args :stream stream)) ;;; utilities (defun whitespace-char-p (char) "Is char an XML whitespace character ?" (or (char= char #\space) (char= char #\tab) (char= char #\return) (char= char #\linefeed))) (defun identifier-char-p (char) "Is char an XML identifier character ?" (or (and (char<= #\A char) (char<= char #\Z)) (and (char<= #\a char) (char<= char #\z)) (and (char<= #\0 char) (char<= char #\9)) (char= char #\-) (char= char #\_) (char= char #\.) (char= char #\:))) (defun skip-whitespace (stream) "Skip over XML whitespace in stream, return first non-whitespace character which was peeked but not read, return nil on eof" (loop (let ((char (peek-char nil stream nil nil))) (if (and char (whitespace-char-p char)) (read-char stream) (return char))))) (defun make-extendable-string (&optional (size 10)) "Make an extendable string which is a one-dimensional character array which is adjustable and has a fill pointer" (make-array size :element-type 'character :adjustable t :fill-pointer 0)) (defun print-string-xml (string stream &key (start 0) end) "Write the characters of string to stream using basic XML conventions" (loop for offset upfrom start below (or end (length string)) for char = (char string offset) do (case char (#\& (write-string "&" stream)) (#\< (write-string "<" stream)) (#\> (write-string ">" stream)) (#\" (write-string """ stream)) ((#\newline #\return #\tab) (write-char char stream)) (t (if (and (<= 32 (char-code char)) (<= (char-code char) 126)) (write-char char stream) (progn (write-string "&#x" stream) (write (char-code char) :stream stream :base 16) (write-char #\; stream))))))) (defun make-standard-entities () "A hashtable mapping XML entity names to their replacement strings, filled with the standard set" (let ((entities (make-hash-table :test #'equal))) (setf (gethash "amp" entities) (string #\&) (gethash "quot" entities) (string #\") (gethash "apos" entities) (string #\') (gethash "lt" entities) (string #\<) (gethash "gt" entities) (string #\>) (gethash "nbsp" entities) (string #\space)) entities)) (defun resolve-entity (stream extendable-string entities &optional (entity (make-extendable-string))) "Read and resolve an XML entity from stream, positioned after the '&' entity marker, accepting &name; &#DEC; and &#xHEX; formats, destructively modifying string, which is also returned, destructively modifying entity, incorrect entity formats result in errors" (loop (let ((char (read-char stream nil nil))) (cond ((null char) (error (parser-error "encountered eof before end of entity"))) ((char= #\; char) (return)) (t (vector-push-extend char entity))))) (if (char= (char entity 0) #\#) (let ((code (if (char= (char entity 1) #\x) (parse-integer entity :start 2 :radix 16 :junk-allowed t) (parse-integer entity :start 1 :radix 10 :junk-allowed t)))) (when (null code) (error (parser-error "encountered incorrect entity &~s;" (list entity) stream))) (vector-push-extend (code-char code) extendable-string)) (let ((value (gethash entity entities))) (if value (loop :for char :across value :do (vector-push-extend char extendable-string)) (error (parser-error "encountered unknown entity &~s;" (list entity) stream))))) extendable-string) ;;; namespace support (defvar *ignore-namespaces* nil "When t, namespaces are ignored like in the old version of S-XML") (defclass xml-namespace () ((uri :documentation "The URI used to identify this namespace" :accessor get-uri :initarg :uri) (prefix :documentation "The preferred prefix assigned to this namespace" :accessor get-prefix :initarg :prefix :initform nil) (package :documentation "The Common Lisp package where this namespace's symbols are interned" :accessor get-package :initarg :package :initform nil)) (:documentation "Describes an XML namespace and how it is handled")) (defmethod print-object ((object xml-namespace) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "~A - ~A" (get-prefix object) (get-uri object)))) (defvar *local-namespace* (make-instance 'xml-namespace :uri "local" :prefix "" :package (find-package :keyword)) "The local (global default) XML namespace") (defvar *xml-namespace* (make-instance 'xml-namespace :uri "http://www.w3.org/XML/1998/namespace" :prefix "xml" :package (or (find-package :xml) (make-package :xml :nicknames '("XML")))) "REC-xml-names-19990114 says the prefix xml is bound to the namespace http://www.w3.org/XML/1998/namespace.") (defvar *known-namespaces* (list *local-namespace* *xml-namespace*) "The list of known/defined namespaces") (defvar *namespaces* `(("xml" . ,*xml-namespace*) ("" . ,*local-namespace*)) "Ordered list of (prefix . XML-namespace) bindings currently in effect - special variable") (defun find-namespace (uri) "Find a registered XML namespace identified by uri" (find uri *known-namespaces* :key #'get-uri :test #'string-equal)) (defun register-namespace (uri prefix package) "Register a new or redefine an existing XML namespace defined by uri with prefix and package" (let ((namespace (find-namespace uri))) (if namespace (setf (get-prefix namespace) prefix (get-package namespace) (find-package package)) (push (setf namespace (make-instance 'xml-namespace :uri uri :prefix prefix :package (find-package package))) *known-namespaces*)) namespace)) (defun find-namespace-binding (prefix namespaces) "Find the XML namespace currently bound to prefix in the namespaces bindings" (cdr (assoc prefix namespaces :test #'string-equal))) (defun split-identifier (identifier) "Split an identifier 'prefix:name' and return (values prefix name)" (when (symbolp identifier) (setf identifier (symbol-name identifier))) (let ((colon-position (position #\: identifier :test #'char=))) (if colon-position (values (subseq identifier 0 colon-position) (subseq identifier (1+ colon-position))) (values nil identifier)))) (defvar *require-existing-symbols* nil "If t, each XML identifier must exist as symbol already") (defvar *auto-export-symbols* t "If t, export newly interned symbols form their packages") (defun resolve-identifier (identifier namespaces &optional as-attribute) "Resolve the string identifier in the list of namespace bindings" (if *ignore-namespaces* (intern identifier :keyword) (flet ((intern-symbol (string package) ; intern string as a symbol in package (if *require-existing-symbols* (let ((symbol (find-symbol string package))) (or symbol (error "Symbol ~s does not exist in ~s" string package))) (let ((symbol (intern string package))) (when (and *auto-export-symbols* (not (eql package (find-package :keyword)))) (export symbol package)) symbol)))) (multiple-value-bind (prefix name) (split-identifier identifier) (if (or (null prefix) (string= prefix "xmlns")) (if as-attribute (intern (if (string= prefix "xmlns") identifier name) (get-package *local-namespace*)) (let ((default-namespace (find-namespace-binding "" namespaces))) (intern-symbol name (get-package default-namespace)))) (let ((namespace (find-namespace-binding prefix namespaces))) (if namespace (intern-symbol name (get-package namespace)) (error "namespace not found for prefix ~s" prefix)))))))) (defvar *auto-create-namespace-packages* t "If t, new packages will be created for namespaces, if needed, named by the prefix") (defun new-namespace (uri &optional prefix) "Register a new namespace for uri and prefix, creating a package if necessary" (if prefix (register-namespace uri prefix (or (find-package prefix) (if *auto-create-namespace-packages* (make-package prefix :nicknames `(,(string-upcase prefix))) (error "Cannot find or create package ~s" prefix)))) (let ((unique-name (loop :for i :upfrom 0 :do (let ((name (format nil "ns-~d" i))) (when (not (find-package name)) (return name)))))) (register-namespace uri unique-name (if *auto-create-namespace-packages* (make-package (string-upcase unique-name) :nicknames `(,unique-name)) (error "Cannot create package ~s" unique-name)))))) (defun extend-namespaces (attributes namespaces) "Given possible 'xmlns[:prefix]' attributes, extend the namespaces bindings" (unless *ignore-namespaces* (let (default-namespace-uri) (loop :for (key . value) :in attributes :do (if (string= key "xmlns") (setf default-namespace-uri value) (multiple-value-bind (prefix name) (split-identifier key) (when (string= prefix "xmlns") (let* ((uri value) (prefix name) (namespace (find-namespace uri))) (unless namespace (setf namespace (new-namespace uri prefix))) (push `(,prefix . ,namespace) namespaces)))))) (when default-namespace-uri (let ((namespace (find-namespace default-namespace-uri))) (unless namespace (setf namespace (new-namespace default-namespace-uri))) (push `("" . ,namespace) namespaces))))) namespaces) (defun print-identifier (identifier stream &optional as-attribute) "Print identifier on stream using namespace conventions" (declare (ignore as-attribute) (special *namespaces*)) (if *ignore-namespaces* (princ identifier stream) (if (symbolp identifier) (let ((package (symbol-package identifier)) (name (symbol-name identifier))) (let* ((namespace (find package *known-namespaces* :key #'get-package)) (prefix (or (car (find namespace *namespaces* :key #'cdr)) (get-prefix namespace)))) (if (string= prefix "") (princ name stream) (format stream "~a:~a" prefix name)))) (princ identifier stream)))) ;;; the parser state (defclass xml-parser-state () ((entities :documentation "A hashtable mapping XML entity names to their replacement stings" :accessor get-entities :initarg :entities :initform (make-standard-entities)) (seed :documentation "The user seed object" :accessor get-seed :initarg :seed :initform nil) (buffer :documentation "The main reusable character buffer" :accessor get-buffer :initform (make-extendable-string)) (mini-buffer :documentation "The secondary, smaller reusable character buffer" :accessor get-mini-buffer :initform (make-extendable-string)) (new-element-hook :documentation "Called when new element starts" ;; Handle the start of a new xml element with name and attributes, ;; receiving seed from previous element (sibling or parent) ;; return seed to be used for first child (content) ;; or directly to finish-element-hook :accessor get-new-element-hook :initarg :new-element-hook :initform #'(lambda (name attributes seed) (declare (ignore name attributes)) seed)) (finish-element-hook :documentation "Called when element ends" ;; Handle the end of an xml element with name and attributes, ;; receiving parent-seed, the seed passed to us when this element started, ;; i.e. passed to our corresponding new-element-hook ;; and receiving seed from last child (content) ;; or directly from new-element-hook ;; return final seed for this element to next element (sibling or parent) :accessor get-finish-element-hook :initarg :finish-element-hook :initform #'(lambda (name attributes parent-seed seed) (declare (ignore name attributes parent-seed)) seed)) (text-hook :documentation "Called when text is found" ;; Handle text in string, found as contents, ;; receiving seed from previous element (sibling or parent), ;; return final seed for this element to next element (sibling or parent) :accessor get-text-hook :initarg :text-hook :initform #'(lambda (string seed) (declare (ignore string)) seed))) (:documentation "The XML parser state passed along all code making up the parser")) (setf (documentation 'get-seed 'function) "Get the initial user seed of an XML parser state" (documentation 'get-entities 'function) "Get the entities hashtable of an XML parser state" (documentation 'get-new-element-hook 'function) "Get the new element hook of an XML parser state" (documentation 'get-finish-element-hook 'function) "Get the finish element hook of an XML parser state" (documentation 'get-text-hook 'function) "Get the text hook of an XML parser state") #-allegro (setf (documentation '(setf get-seed) 'function) "Set the initial user seed of an XML parser state" (documentation '(setf get-entities) 'function) "Set the entities hashtable of an XML parser state" (documentation '(setf get-new-element-hook) 'function) "Set the new element hook of an XML parser state" (documentation '(setf get-finish-element-hook) 'function) "Set the finish element hook of an XML parser state" (documentation '(setf get-text-hook) 'function) "Set the text hook of an XML parser state") (defmethod get-mini-buffer :after ((state xml-parser-state)) "Reset and return the reusable mini buffer" (with-slots (mini-buffer) state (setf (fill-pointer mini-buffer) 0))) (defmethod get-buffer :after ((state xml-parser-state)) "Reset and return the main reusable buffer" (with-slots (buffer) state (setf (fill-pointer buffer) 0))) ;;; parser support (defun parse-whitespace (stream extendable-string) "Read and collect XML whitespace from stream in string which is destructively modified, return first non-whitespace character which was peeked but not read, return nil on eof" (loop (let ((char (peek-char nil stream nil nil))) (if (and char (whitespace-char-p char)) (vector-push-extend (read-char stream) extendable-string) (return char))))) (defun parse-string (stream state &optional (string (make-extendable-string))) "Read and return an XML string from stream, delimited by either single or double quotes, the stream is expected to be on the opening delimiter, at the end the closing delimiter is also read, entities are resolved, eof before end of string is an error" (let ((delimiter (read-char stream nil nil)) (char)) (when (or (null delimiter) (not (or (char= delimiter #\') (char= delimiter #\")))) (error (parser-error "expected string delimiter" nil stream))) (loop (setf char (read-char stream nil nil)) (cond ((null char) (error (parser-error "encountered eof before end of string"))) ((char= char delimiter) (return)) ((char= char #\&) (resolve-entity stream string (get-entities state) (get-mini-buffer state))) (t (vector-push-extend char string)))) string)) (defun parse-text (stream state extendable-string) "Read and collect XML text from stream in string which is destructively modified, the text ends with a '<', which is peeked and returned, entities are resolved, eof is considered an error" (let (char) (loop (setf char (peek-char nil stream nil nil)) (when (null char) (error (parser-error "encountered unexpected eof in text"))) (when (char= char #\<) (return)) (read-char stream) (if (char= char #\&) (resolve-entity stream extendable-string (get-entities state) (get-mini-buffer state)) (vector-push-extend char extendable-string))) char)) (defun parse-identifier (stream &optional (identifier (make-extendable-string))) "Read and returns an XML identifier from stream, positioned at the start of the identifier, ending with the first non-identifier character, which is peeked, the identifier is written destructively into identifier which is also returned" (loop (let ((char (peek-char nil stream nil nil))) (cond ((and char (identifier-char-p char)) (read-char stream) (vector-push-extend char identifier)) (t (return identifier)))))) (defun skip-comment (stream) "Skip an XML comment in stream, positioned after the opening '' sequence, unexpected eof or a malformed closing sequence result in a error" (let ((dashes-to-read 2)) (loop (if (zerop dashes-to-read) (return)) (let ((char (read-char stream nil nil))) (if (null char) (error (parser-error "encountered unexpected eof for comment"))) (if (char= char #\-) (decf dashes-to-read) (setf dashes-to-read 2))))) (if (char/= (read-char stream nil nil) #\>) (error (parser-error "expected > ending comment" nil stream)))) (defun read-cdata (stream state &optional (string (make-extendable-string))) "Reads in the CDATA and calls the callback for CDATA if it exists" ;; we already read the (let ((char #\space) (last-3-characters (list #\[ #\A #\T)) (pattern (list #\> #\] #\]))) (loop (setf char (read-char stream nil nil)) (when (null char) (error (parser-error "encountered unexpected eof in text"))) (push char last-3-characters) (setf (cdddr last-3-characters) nil) (cond ((equal last-3-characters pattern) (setf (fill-pointer string) (- (fill-pointer string) 2)) (setf (get-seed state) (funcall (get-text-hook state) (copy-seq string) (get-seed state))) (return-from read-cdata)) (t (vector-push-extend char string)))))) (defun skip-special-tag (stream state) "Skip an XML special tag (comments and processing instructions) in stream, positioned after the opening '<', unexpected eof is an error" ;; opening < has been read, consume ? or ! (read-char stream) (let ((char (read-char stream nil nil))) ;; see if we are dealing with a comment (when (char= char #\-) (setf char (read-char stream nil nil)) (when (char= char #\-) (skip-comment stream) (return-from skip-special-tag))) ;; maybe we are dealing with CDATA? (when (and (char= char #\[) (loop :for pattern :across "CDATA[" :for char = (read-char stream nil nil) :when (null char) :do (error (parser-error "encountered unexpected eof in cdata")) :always (char= char pattern))) (read-cdata stream state (get-buffer state)) (return-from skip-special-tag)) ;; loop over chars, dealing with strings (skipping their content) ;; and counting opening and closing < and > chars (let ((taglevel 1) (string-delimiter)) (loop (when (zerop taglevel) (return)) (setf char (read-char stream nil nil)) (when (null char) (error (parser-error "encountered unexpected eof for special (! or ?) tag" nil stream))) (if string-delimiter ;; inside a string we only look for a closing string delimiter (when (char= char string-delimiter) (setf string-delimiter nil)) ;; outside a string we count < and > and watch out for strings (cond ((or (char= char #\') (char= char #\")) (setf string-delimiter char)) ((char= char #\<) (incf taglevel)) ((char= char #\>) (decf taglevel)))))))) ;;; the XML parser proper (defun parse-xml-element-attributes (stream state) "Parse XML element attributes from stream positioned after the tag identifier, returning the attributes as an assoc list, ending at either a '>' or a '/' which is peeked and also returned" (declare (special *namespaces*)) (let (char attributes) (loop ;; skip whitespace separating items (setf char (skip-whitespace stream)) ;; start tag attributes ends with > or /> (when (and char (or (char= char #\>) (char= char #\/))) (return)) ;; read the attribute key (let ((key (copy-seq (parse-identifier stream (get-mini-buffer state))))) ;; skip separating whitespace (setf char (skip-whitespace stream)) ;; require = sign (and consume it if present) (if (and char (char= char #\=)) (read-char stream) (error (parser-error "expected =" nil stream))) ;; skip separating whitespace (skip-whitespace stream) ;; read the attribute value as a string (push (cons key (copy-seq (parse-string stream state (get-buffer state)))) attributes))) ;; return attributes peek char ending loop (values attributes char))) (defun parse-xml-element (stream state) "Parse and return an XML element from stream, positioned after the opening '<'" (declare (special *namespaces*)) ;; opening < has been read (when (char= (peek-char nil stream nil nil) #\!) (skip-special-tag stream state) (return-from parse-xml-element)) (let (char buffer open-tag parent-seed has-children) (setf parent-seed (get-seed state)) ;; read tag name (no whitespace between < and name ?) (setf open-tag (copy-seq (parse-identifier stream (get-mini-buffer state)))) ;; tag has been read, read attributes if any (multiple-value-bind (attributes peeked-char) (parse-xml-element-attributes stream state) (let ((*namespaces* (extend-namespaces attributes *namespaces*))) (setf open-tag (resolve-identifier open-tag *namespaces*) attributes (loop :for (key . value) :in attributes :collect (cons (resolve-identifier key *namespaces* t) value))) (setf (get-seed state) (funcall (get-new-element-hook state) open-tag attributes (get-seed state))) (setf char peeked-char) (when (char= char #\/) ;; handle solitary tag of the form (read-char stream) (setf char (read-char stream nil nil)) (if (char= #\> char) (progn (setf (get-seed state) (funcall (get-finish-element-hook state) open-tag attributes parent-seed (get-seed state))) (return-from parse-xml-element)) (error (parser-error "expected >" nil stream)))) ;; consume > (read-char stream) (loop (setf buffer (get-buffer state)) ;; read whitespace into buffer (setf char (parse-whitespace stream buffer)) ;; see what ended the whitespace scan (cond ((null char) (error (parser-error "encountered unexpected eof handling ~a" (list open-tag)))) ((char= char #\<) ;; consume the < (read-char stream) (if (char= (peek-char nil stream nil nil) #\/) (progn ;; handle the matching closing tag and done ;; if we read whitespace as this (leaf) element's contents, it is significant (when (and (not has-children) (plusp (length buffer))) (setf (get-seed state) (funcall (get-text-hook state) (copy-seq buffer) (get-seed state)))) (read-char stream) (let ((close-tag (resolve-identifier (parse-identifier stream (get-mini-buffer state)) *namespaces*))) (unless (eq open-tag close-tag) (error (parser-error "found <~a> not matched by but by <~a>" (list open-tag open-tag close-tag) stream))) (unless (char= (read-char stream nil nil) #\>) (error (parser-error "expected >" nil stream))) (setf (get-seed state) (funcall (get-finish-element-hook state) open-tag attributes parent-seed (get-seed state)))) (return)) ;; handle child tag and loop, no hooks to call here ;; whitespace between child elements is skipped (progn (setf has-children t) (parse-xml-element stream state)))) (t ;; no child tag, concatenate text to whitespace in buffer ;; handle text content and loop (setf char (parse-text stream state buffer)) (setf (get-seed state) (funcall (get-text-hook state) (copy-seq buffer) (get-seed state)))))))))) (defun start-parse-xml (stream &optional (state (make-instance 'xml-parser-state))) "Parse and return a toplevel XML element from stream, using parser state" (loop (let ((char (skip-whitespace stream))) (when (null char) (return-from start-parse-xml)) ;; skip whitespace until start tag (unless (char= char #\<) (error (parser-error "expected <" nil stream))) (read-char stream) ; consume peeked char (setf char (peek-char nil stream nil nil)) (if (or (char= char #\!) (char= char #\?)) ;; deal with special tags (skip-special-tag stream state) (progn ;; read the main element (parse-xml-element stream state) (return-from start-parse-xml (get-seed state))))))) ;;;; eof roslisp-1.9.20/s-xml/test/000077500000000000000000000000001270365674000153275ustar00rootroot00000000000000roslisp-1.9.20/s-xml/test/all-tests.lisp000066400000000000000000000013421270365674000201300ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: all-tests.lisp,v 1.1.1.1 2004/06/07 18:49:58 scaekenberghe Exp $ ;;;; ;;;; Load and execute all unit and functional tests ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (load (merge-pathnames "test-xml" *load-pathname*) :verbose t) (load (merge-pathnames "test-xml-struct-dom" *load-pathname*) :verbose t) (load (merge-pathnames "test-lxml-dom" *load-pathname*) :verbose t) (load (merge-pathnames "test-sxml-dom" *load-pathname*) :verbose t) ;;;; eofroslisp-1.9.20/s-xml/test/ant-build-file.xml000066400000000000000000000207131270365674000206500ustar00rootroot00000000000000 roslisp-1.9.20/s-xml/test/counter.lisp000066400000000000000000000031341270365674000177000ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: counter.lisp,v 1.2 2004/06/11 11:14:43 scaekenberghe Exp $ ;;;; ;;;; A simple SSAX counter example that can be used as a performance test ;;;; ;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (defclass count-xml-seed () ((elements :initform 0) (attributes :initform 0) (characters :initform 0))) (defun count-xml-new-element-hook (name attributes seed) (declare (ignore name)) (incf (slot-value seed 'elements)) (incf (slot-value seed 'attributes) (length attributes)) seed) (defun count-xml-text-hook (string seed) (incf (slot-value seed 'characters) (length string)) seed) (defun count-xml (in) "Parse a toplevel XML element from stream in, counting elements, attributes and characters" (start-parse-xml in (make-instance 'xml-parser-state :seed (make-instance 'count-xml-seed) :new-element-hook #'count-xml-new-element-hook :text-hook #'count-xml-text-hook))) (defun count-xml-file (pathname) "Parse XMl from the file at pathname, counting elements, attributes and characters" (with-open-file (in pathname) (let ((result (count-xml in))) (with-slots (elements attributes characters) result (format t "~a contains ~d XML elements, ~d attributes and ~d characters.~%" pathname elements attributes characters))))) ;;;; eof roslisp-1.9.20/s-xml/test/echo.lisp000066400000000000000000000040171270365674000171400ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: echo.lisp,v 1.1 2005/08/17 13:44:30 scaekenberghe Exp $ ;;;; ;;;; A simple example as well as a useful tool: parse, echo and pretty print XML ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (defun indent (stream count) (loop :repeat (* count 2) :do (write-char #\space stream))) (defclass echo-xml-seed () ((stream :initarg :stream) (level :initarg :level :initform 0))) #+NIL (defmethod print-object ((seed echo-xml-seed) stream) (with-slots (stream level) seed (print-unreadable-object (seed stream :type t) (format stream "level=~d" level)))) (defun echo-xml-new-element-hook (name attributes seed) (with-slots (stream level) seed (indent stream level) (format stream "<~a" name) (dolist (attribute (reverse attributes)) (format stream " ~a=\'" (car attribute)) (print-string-xml (cdr attribute) stream) (write-char #\' stream)) (format stream ">~%") (incf level) seed)) (defun echo-xml-finish-element-hook (name attributes parent-seed seed) (declare (ignore attributes parent-seed)) (with-slots (stream level) seed (decf level) (indent stream level) (format stream "~%" name) seed)) (defun echo-xml-text-hook (string seed) (with-slots (stream level) seed (indent stream level) (print-string-xml string stream) (terpri stream) seed)) (defun echo-xml (in out) "Parse a toplevel XML element from stream in, echoing and pretty printing the result to stream out" (start-parse-xml in (make-instance 'xml-parser-state :seed (make-instance 'echo-xml-seed :stream out) :new-element-hook #'echo-xml-new-element-hook :finish-element-hook #'echo-xml-finish-element-hook :text-hook #'echo-xml-text-hook))) ;;;; eof roslisp-1.9.20/s-xml/test/plist.xml000066400000000000000000000017061270365674000172100ustar00rootroot00000000000000 AppleDockIconEnabled AppleNavServices:GetFile:0:Path file://localhost/Users/sven/Pictures/ AppleNavServices:GetFile:0:Position AOUBXw== AppleNavServices:GetFile:0:Size AAAAAAFeAcI= AppleNavServices:PutFile:0:Disclosure AQ== AppleNavServices:PutFile:0:Path file://localhost/Users/sven/Desktop/ AppleNavServices:PutFile:0:Position AUIBVQ== AppleNavServices:PutFile:0:Size AAAAAACkAdY= AppleSavePanelExpanded YES NSDefaultOpenDirectory ~/Desktop NSNoBigString roslisp-1.9.20/s-xml/test/remove-markup.lisp000066400000000000000000000013671270365674000210210ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: remove-markup.lisp,v 1.1 2004/06/11 11:14:43 scaekenberghe Exp $ ;;;; ;;;; Remove markup from an XML document using the SSAX interface ;;;; ;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (defun remove-xml-markup (in) (let* ((state (make-instance 'xml-parser-state :text-hook #'(lambda (string seed) (cons string seed)))) (result (start-parse-xml in state))) (apply #'concatenate 'string (nreverse result)))) ;;;; eofroslisp-1.9.20/s-xml/test/simple.xml000066400000000000000000000001661270365674000173450ustar00rootroot00000000000000 Hello World! roslisp-1.9.20/s-xml/test/test-lxml-dom.lisp000066400000000000000000000046221270365674000207320ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: test-lxml-dom.lisp,v 1.2 2005/11/06 12:44:48 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for lxml-dom.lisp ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (assert (equal (with-input-from-string (stream " ") (parse-xml stream :output-type :lxml)) :|foo|)) (assert (equal (parse-xml-string "this is some text" :output-type :lxml) '(:|tag1| ((:|tag2| :|att1| "one")) "this is some text"))) (assert (equal (parse-xml-string "<foo>" :output-type :lxml) '(:TAG ""))) (assert (equal (parse-xml-string "

This is some bold text, with a leading & trailing space

" :output-type :lxml) '(:p ((:index :item "one")) " This is some " (:b "bold") " text, with a leading & trailing space "))) (assert (consp (parse-xml-file (merge-pathnames "xhtml-page.xml" *load-pathname*) :output-type :lxml))) (assert (consp (parse-xml-file (merge-pathnames "ant-build-file.xml" *load-pathname*) :output-type :lxml))) (assert (consp (parse-xml-file (merge-pathnames "plist.xml" *load-pathname*) :output-type :lxml))) (assert (string-equal (print-xml-string :|foo| :input-type :lxml) "")) (assert (string-equal (print-xml-string '((:|foo| :|bar| "1")) :input-type :lxml) "")) (assert (string-equal (print-xml-string '(:foo "some text") :input-type :lxml) "some text")) (assert (string-equal (print-xml-string '(:|foo| :|bar|) :input-type :lxml) "")) (assert (string-equal (second (with-input-from-string (stream "Hello, world!]]>") (parse-xml stream :output-type :lxml))) "Hello, world!")) (assert (string-equal (second (with-input-from-string (stream "Hello, < world!]]>") (parse-xml stream :output-type :lxml))) "Hello, < world!")) ;;;; eofroslisp-1.9.20/s-xml/test/test-sxml-dom.lisp000066400000000000000000000036031270365674000207370ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: test-sxml-dom.lisp,v 1.1.1.1 2004/06/07 18:49:59 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for sxml-dom.lisp ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (assert (equal (with-input-from-string (stream " ") (parse-xml stream :output-type :sxml)) '(:|foo|))) (assert (equal (parse-xml-string "this is some text" :output-type :sxml) '(:|tag1| (:|tag2| (:@ (:|att1| "one"))) "this is some text"))) (assert (equal (parse-xml-string "<foo>" :output-type :sxml) '(:TAG ""))) (assert (equal (parse-xml-string "

This is some bold text, with a leading & trailing space

" :output-type :sxml) '(:p (:index (:@ (:item "one"))) " This is some " (:b "bold") " text, with a leading & trailing space "))) (assert (consp (parse-xml-file (merge-pathnames "xhtml-page.xml" *load-pathname*) :output-type :sxml))) (assert (consp (parse-xml-file (merge-pathnames "ant-build-file.xml" *load-pathname*) :output-type :sxml))) (assert (consp (parse-xml-file (merge-pathnames "plist.xml" *load-pathname*) :output-type :sxml))) (assert (string-equal (print-xml-string '(:|foo|) :input-type :sxml) "")) (assert (string-equal (print-xml-string '(:|foo| (:@ (:|bar| "1"))) :input-type :sxml) "")) (assert (string-equal (print-xml-string '(:foo "some text") :input-type :sxml) "some text")) (assert (string-equal (print-xml-string '(:|foo| (:|bar|)) :input-type :sxml) "")) ;;;; eofroslisp-1.9.20/s-xml/test/test-xml-struct-dom.lisp000066400000000000000000000050201270365674000220710ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: test-xml-struct-dom.lisp,v 1.2 2005/08/29 15:01:49 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for xml-struct-dom.lisp ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (assert (xml-equal (with-input-from-string (stream " ") (parse-xml stream :output-type :xml-struct)) (make-xml-element :name :|foo|))) (assert (xml-equal (parse-xml-string "this is some text" :output-type :xml-struct) (make-xml-element :name :|tag1| :children (list (make-xml-element :name :|tag2| :attributes '((:|att1| . "one"))) "this is some text")))) (assert (xml-equal (parse-xml-string "<foo>" :output-type :xml-struct) (make-xml-element :name :|tag| :children (list "")))) (assert (xml-equal (parse-xml-string "

This is some bold text, with a leading & trailing space

" :output-type :xml-struct) (make-xml-element :name :p :children (list (make-xml-element :name :index :attributes '((:item . "one"))) " This is some " (make-xml-element :name :b :children (list "bold")) " text, with a leading & trailing space ")))) (assert (xml-element-p (parse-xml-file (merge-pathnames "xhtml-page.xml" *load-pathname*) :output-type :xml-struct))) (assert (xml-element-p (parse-xml-file (merge-pathnames "ant-build-file.xml" *load-pathname*) :output-type :xml-struct))) (assert (xml-element-p (parse-xml-file (merge-pathnames "plist.xml" *load-pathname*) :output-type :xml-struct))) (assert (string-equal (print-xml-string (make-xml-element :name "foo") :input-type :xml-struct) "")) (assert (string-equal (print-xml-string (make-xml-element :name "foo" :attributes '((:|bar| . "1"))) :input-type :xml-struct) "")) (assert (string-equal (print-xml-string (make-xml-element :name "foo" :children (list "some text")) :input-type :xml-struct) "some text")) (assert (string-equal (print-xml-string (make-xml-element :name "foo" :children (list (make-xml-element :name "bar"))) :input-type :xml-struct) "")) ;;;; eofroslisp-1.9.20/s-xml/test/test-xml.lisp000066400000000000000000000043371270365674000200040ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: test-xml.lisp,v 1.3 2005/11/06 12:44:48 scaekenberghe Exp $ ;;;; ;;;; Unit and functional tests for xml.lisp ;;;; ;;;; Copyright (C) 2002, 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (assert (whitespace-char-p (character " "))) (assert (whitespace-char-p (character " "))) (assert (whitespace-char-p (code-char 10))) (assert (whitespace-char-p (code-char 13))) (assert (not (whitespace-char-p #\A))) (assert (char= (with-input-from-string (stream " ABC") (skip-whitespace stream)) #\A)) (assert (char= (with-input-from-string (stream "ABC") (skip-whitespace stream)) #\A)) (assert (string-equal (with-output-to-string (stream) (print-string-xml "" stream)) "<foo>")) (assert (string-equal (with-output-to-string (stream) (print-string-xml "' '" stream)) "' '")) (assert (let ((string (map 'string #'identity '(#\return #\tab #\newline)))) (string-equal (with-output-to-string (stream) (print-string-xml string stream)) string))) (defun simple-echo-xml (in out) (start-parse-xml in (make-instance 'xml-parser-state :new-element-hook #'(lambda (name attributes seed) (declare (ignore seed)) (format out "<~a~:{ ~a='~a'~}>" name (mapcar #'(lambda (p) (list (car p) (cdr p))) (reverse attributes)))) :finish-element-hook #'(lambda (name attributes parent-seed seed) (declare (ignore attributes parent-seed seed)) (format out "" name)) :text-hook #'(lambda (string seed) (declare (ignore seed)) (princ string out))))) (defun simple-echo-xml-string (string) (with-input-from-string (in string) (with-output-to-string (out) (simple-echo-xml in out)))) (assert (let ((xml "TextMore text!")) (equal (simple-echo-xml-string xml) xml))) (assert (let ((xml "

")) (equal (simple-echo-xml-string xml) xml))) ;;;; eofroslisp-1.9.20/s-xml/test/tracer.lisp000066400000000000000000000042351270365674000175040ustar00rootroot00000000000000;;;; -*- mode: lisp -*- ;;;; ;;;; $Id: tracer.lisp,v 1.2 2004/06/11 11:14:43 scaekenberghe Exp $ ;;;; ;;;; A simple SSAX tracer example that can be used to understand how the hooks are called ;;;; ;;;; Copyright (C) 2004 Sven Van Caekenberghe, Beta Nine BVBA. ;;;; ;;;; You are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser General Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :s-xml) (defun trace-xml-log (level msg &rest args) (indent *standard-output* level) (apply #'format *standard-output* msg args) (terpri *standard-output*)) (defun trace-xml-new-element-hook (name attributes seed) (let ((new-seed (cons (1+ (car seed)) (1+ (cdr seed))))) (trace-xml-log (car seed) "(new-element :name ~s :attributes ~:[()~;~:*~s~] :seed ~s) => ~s" name attributes seed new-seed) new-seed)) (defun trace-xml-finish-element-hook (name attributes parent-seed seed) (let ((new-seed (cons (1- (car seed)) (1+ (cdr seed))))) (trace-xml-log (car parent-seed) "(finish-element :name ~s :attributes ~:[()~;~:*~s~] :parent-seed ~s :seed ~s) => ~s" name attributes parent-seed seed new-seed) new-seed)) (defun trace-xml-text-hook (string seed) (let ((new-seed (cons (car seed) (1+ (cdr seed))))) (trace-xml-log (car seed) "(text :string ~s :seed ~s) => ~s" string seed new-seed) new-seed)) (defun trace-xml (in) "Parse and trace a toplevel XML element from stream in" (start-parse-xml in (make-instance 'xml-parser-state :seed (cons 0 0) ;; seed car is xml element nesting level ;; seed cdr is ever increasing from element to element :new-element-hook #'trace-xml-new-element-hook :finish-element-hook #'trace-xml-finish-element-hook :text-hook #'trace-xml-text-hook))) (defun trace-xml-file (pathname) "Parse and trace XMl from the file at pathname" (with-open-file (in pathname) (trace-xml in))) ;;;; eof roslisp-1.9.20/s-xml/test/xhtml-page.xml000066400000000000000000000300111270365674000201120ustar00rootroot00000000000000 XHTML Tutorial

HOME

XHTML Tutorial
XHTML HOME
XHTML Introduction
XHTML Why
XHTML v HTML
XHTML Syntax
XHTML DTD
XHTML HowTo
XHTML Validation

Quiz
XHTML Quiz

References
XHTML Tag List
XHTML Attributes
XHTML Events
Corel XMetal 3
Please Visit Our Sponsors !

XHTML Tutorial

Previous Next

XHTML Tutorial

XHTML is the next generation of HTML! In our XHTML tutorial you will learn the difference between HTML and XHTML, and how to use XHTML in your future applications. You will also see how we converted this Web site into XHTML. Start Learning XHTML!

XHTML Quiz Test

Test your XHTML skills at W3Schools! Start XHTML Quiz! 

XHTML References

At W3Schools you will find complete XHTML references about tags, attributes and events. XHTML 1.0 References.

Table of Contents

Introduction to XHTML
This chapter gives a brief introduction to XHTML and explains what XHTML is.

XHTML - Why?
This chapter explains why we needed a new language like XHTML.

Differences between XHTML and HTML
This chapter explains the main differences in syntax between XHTML and HTML.

XHTML Syntax 
This chapter explains the basic syntax of XHTML.

XHTML DTD 
This chapter explains the three different XHTML Document Type Definitions.

XHTML HowTo
This chapter explains how this web site was converted from HTML to XHTML.

XHTML Validation
This chapter explains how to validate XHTML documents.

XHTML References

XHTML 1.0 Reference
Our complete XHTML 1.0 reference is an alphabetical list of all XHTML tags with lots of  examples and tips.

XHTML 1.0 Standard Attributes
All the tags have attributes. The attributes for each tag are listed in the examples in the "XHTML 1.0 Reference" page. The attributes listed here are the core and language attributes all the tags has as standard (with few exceptions). This reference describes the attributes, and shows possible values for each.

XHTML 1.0 Event Attributes
All the standard event attributes of the tags. This reference describes the attributes, and shows possible values for each.

Previous Next

Jump to: Top of Page or HOME or Printer Friendly Printer friendly page

Search W3Schools:

What Others Say About Us

Does the world know about us? Check out these places:

Dogpile Alta Vista MSN Google Excite Lycos Yahoo Ask Jeeves

We Help You For Free. You Can Help Us!

W3Schools is for training only. We do not warrant its correctness or its fitness for use. The risk of using it remains entirely with the user. While using this site, you agree to have read and accepted our terms of use and privacy policy.

Copyright 1999-2002 by Refsnes Data. All Rights Reserved

Validate How we converted to XHTML Validate

Web charting
Web based charting
for ASP.NET


Your own Web Site?

Read W3Schools
Hosting Tutorial


$15 Domain Name
Registration
Save $20 / year!


SELECTED LINKS

University Online
Master Degree
Bachelor Degree

Web Software

The Future of
Web Development

Jobs and Careers

Web Security
Web Statistics
Web Standards


Recommended
Reading:

HTML XHTML


PARTNERS

W3Schools
TopXML
VisualBuilder
XMLPitstop
DevelopersDex
DevGuru
Programmers Heaven
The Code Project
Tek Tips Forum
ZVON.ORG
TopXML Search
roslisp-1.9.20/scripts/000077500000000000000000000000001270365674000147775ustar00rootroot00000000000000roslisp-1.9.20/scripts/compile_load_manifest000077500000000000000000000004311270365674000212400ustar00rootroot00000000000000#!/usr/bin/env sh SBCL_CMD="/usr/bin/env sbcl" ROSLISP_PATH=`rospack find roslisp` if [ -z "$ROSLISP_PATH" ]; then echo "roslisp not found" exit 1 fi $SBCL_CMD --noinform --end-runtime-options --noprint --non-interactive \ --load $ROSLISP_PATH/scripts/roslisp-sbcl-init roslisp-1.9.20/scripts/make-roslisp-exec.lisp000066400000000000000000000110131270365674000212140ustar00rootroot00000000000000(require :asdf) (in-package :cl-user) (flet ((failure-quit (&key exit-code) (if (find-symbol "EXIT" 'sb-ext) (funcall (intern "EXIT" 'sb-ext) :code exit-code) (funcall (intern "QUIT" 'sb-ext) :unix-status exit-code)))) (let ((p (sb-ext:posix-getenv "ROS_ROOT"))) (unless p (error "ROS_ROOT not set")) (let ((roslisp-path (merge-pathnames (make-pathname :directory '(:relative "asdf")) (ros-load:ros-package-path "roslisp"))) (output-filename (pathname (fifth sb-ext:*posix-argv*)))) (unless (sb-ext:posix-getenv "ROS_DEBBUILD") (handler-case (let ((ros-load:*current-ros-package* (second sb-ext:*posix-argv*))) (asdf:operate 'asdf:compile-op (third sb-ext:*posix-argv*))) (error (e) (format *error-output* "Compilation failed due to condition: ~a~&" e) (failure-quit :exit-code 1)))) (with-open-file (strm (ensure-directories-exist output-filename) :if-exists :supersede :direction :output) (let ((*standard-output* strm)) (pprint '(require :asdf)) (pprint '(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file)) (handler-case (call-next-method o c) ;; If a fasl was stale, try to recompile and load (once). (sb-ext:invalid-fasl () (asdf:perform (make-instance 'asdf:compile-op) c) (call-next-method))))) (pprint '(push :roslisp-standalone-executable *features*)) (pprint '(declaim (sb-ext:muffle-conditions sb-ext:compiler-note))) (pprint `(push ,roslisp-path asdf:*central-registry*)) (pprint '(defun roslisp-debugger-hook (condition me) (declare (ignore me)) (flet ((failure-quit (&key abort-p) (if (find-symbol "EXIT" 'sb-ext) (funcall (intern "EXIT" 'sb-ext) :code 1 :abort abort-p) (funcall (intern "QUIT" 'sb-ext) :unix-status 1 :recklessly-p abort-p)))) (handler-case (progn (format *error-output* "~&Roslisp exiting due to condition: ~a~&" condition) (finish-output *error-output*) (failure-quit)) (condition () (failure-quit :abort-p t)))))) (pprint '(unless (let ((v (sb-ext:posix-getenv "ROSLISP_BACKTRACE_ON_ERRORS"))) (and (stringp v) (> (length v) 0))) (setq sb-ext:*invoke-debugger-hook* #'roslisp-debugger-hook))) (pprint `(handler-bind ((style-warning #'muffle-warning) (warning #'print)) (asdf:operate 'asdf:load-op :ros-load-manifest :verbose nil) (setf (symbol-value (intern "*CURRENT-ROS-PACKAGE*" :ros-load)) ,(second sb-ext:*posix-argv*)) (let ((*standard-output* (make-broadcast-stream)) (sys ,(third sb-ext:*posix-argv*))) (handler-case (asdf:operate 'asdf:load-op sys :verbose nil) (asdf:missing-component (c) (error "Couldn't find asdf system (filename ~a.asd and system name ~a) or some dependency. Original condition was ~a." sys sys c)))) (load (merge-pathnames (make-pathname :name ,(format nil "~a-init.lisp" (pathname-name output-filename)) :directory '(:relative "roslisp" ,(second sb-ext:*posix-argv*))) (funcall (symbol-function (intern "ROS-HOME" :ros-load)))) :if-does-not-exist nil) (funcall (symbol-function (read-from-string ,(fourth sb-ext:*posix-argv*)))) (if (find-symbol "EXIT" 'sb-ext) (funcall (intern "EXIT" 'sb-ext)) (funcall (intern "QUIT" 'sb-ext)))))))) (failure-quit :exit-code 0))) roslisp-1.9.20/scripts/make_exe_script000077500000000000000000000007651270365674000200770ustar00rootroot00000000000000#!/usr/bin/env sh ROSLISP_PATH=`rospack find roslisp` if [ -z "$ROSLISP_PATH" ]; then echo "roslisp not found" exit 1 fi if [ $# = 4 ]; then pkg=$1 system=$2 entry=$3 output=$4 cat > $output < " exit 1 fi roslisp-1.9.20/scripts/make_node_exec000077500000000000000000000020331270365674000176510ustar00rootroot00000000000000#!/usr/bin/env sh SBCL_CMD="/usr/bin/env sbcl" ROSLISP_PATH=`rospack find roslisp` if [ -z "$ROSLISP_PATH" ]; then echo "roslisp not found" exit 1 fi if [ $# = 4 ]; then pkg=$1 system=$2 entry=$3 output=$4 echo "Generating Lisp executable." $SBCL_CMD --noinform --end-runtime-options --noprint --non-interactive \ --load $ROSLISP_PATH/scripts/roslisp-sbcl-init \ --load $ROSLISP_PATH/scripts/make-roslisp-exec.lisp \ $pkg $system $entry $output.lisp \ --script \ || exit $? cat > $output < " exit 1 fi roslisp-1.9.20/scripts/make_roslisp_image000077500000000000000000000021251270365674000205570ustar00rootroot00000000000000#!/bin/bash # make-roslisp-image IMAGE_NAME # Creates or overwrites a file IMAGE_NAME containing the Lisp image that includes Roslisp # Will be used as an intermediate file when making individual executables for ROS nodes if [[ $# == 1 ]]; then # Force certain files to be recompiled touch `rospack find roslisp`/msg.lisp touch `rospack find roslisp`/utils/hash-utils.lisp sbcl --noinform --userinit "`rospack find roslisp`/scripts/roslisp-sbcl-init" --eval "(setf sb-ext:*invoke-debugger-hook* #'(lambda (a b) (declare (ignore b)) (format t \"Roslisp compilation dying due to error ~a\" a) (sb-ext:quit :unix-status 70)))" --eval "(handler-bind ((warning #'(lambda (c) (format t \"~&Ignoring warning ~a\" c) (muffle-warning)))) (asdf:operate 'asdf:load-op ':roslisp))" --eval "(setf sb-ext:*invoke-debugger-hook* #'roslisp:standalone-exec-debug-hook roslisp:*running-from-command-line* t)" --eval "(sb-ext:save-lisp-and-die \"$1\")" touch `rospack find roslisp`/msg.lisp touch `rospack find roslisp`/utils/hash-utils.lisp else echo "Usage: make-roslisp-image IMAGE_NAME" firoslisp-1.9.20/scripts/roslisp-sbcl-init000066400000000000000000000021661270365674000203040ustar00rootroot00000000000000;; Initialization for sbcl when compiling roslisp (require :asdf) ;;; Handle recompilation of fasls with wrong version. (defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file)) (handler-case (call-next-method o c) ;; If a fasl was stale, try to recompile and load (once). (sb-ext:invalid-fasl () (asdf:perform (make-instance 'asdf:compile-op) c) (call-next-method)))) ;;; Add appropriate paths for asdf to look for ros-load-manifest. We ;;; use the path of this file as base. (unless (asdf:find-system :ros-load-manifest nil) (unless *load-truename* (error 'simple-error :format-control "*LOAD-TRUENAME* not bound. This script needs to be loaded with the --load parameter.")) (let ((load-manifest-directory (parse-namestring (concatenate 'string (directory-namestring *load-truename*) "../load-manifest/")))) (push load-manifest-directory asdf:*central-registry*))) (asdf:operate 'asdf:load-op :ros-load-manifest) roslisp-1.9.20/scripts/run-roslisp-script.sh000077500000000000000000000054611270365674000211430ustar00rootroot00000000000000#!/usr/bin/env sh "true";exec /usr/bin/env /usr/bin/sbcl --noinform --end-runtime-options --noprint --no-userinit --disable-debugger --script "$0" "$@" ;; This LISP script can be used to launch LISP scripts that depend on ros functinoality. ;; To use it make the following the first two lines of your script: ;; ;; #!/usr/bin/env sh ;; "true";exec /usr/bin/env rosrun roslisp run-roslisp-script.sh --script "$0" "$@" ;; ;; You can then load asdf systems from ROS (like roslisp) using: ;; (ros-load:load-system "roslisp" "roslisp") ;; ;; This script initializes ros lookup of packages, and wraps SBCL to suppress unwanted output for scripts (REQUIRE :ASDF) (labels ((get-roslisp-path () ;; calls rospack to find path to roslisp (let ((rospack-process (run-program "rospack" '("find" "roslisp") :search t :output :stream))) (when rospack-process (unwind-protect (with-open-stream (o (process-output rospack-process)) (concatenate 'string (car (loop for line := (read-line o nil nil) while line collect line)) "/load-manifest/")) (process-close rospack-process))))) (load-ros-lookup () ;; make sure roslisp is in asdf central registry (PUSH (get-roslisp-path) ASDF:*CENTRAL-REGISTRY*) ;; load ros-load-manifest, defining e.g. "ros-load:load-system" (ASDF:OPERATE 'ASDF:LOAD-OP :ROS-LOAD-MANIFEST :VERBOSE NIL))) (load-ros-lookup)) (PUSH :ROSLISP-STANDALONE-EXECUTABLE *FEATURES*) ;; handle conditions (LABELS ((ROSLISP-DEBUGGER-HOOK (CONDITION ME) (DECLARE (IGNORE ME)) (FLET ((FAILURE-QUIT (&KEY RECKLESSLY-P) (QUIT :UNIX-STATUS 1 :RECKLESSLY-P RECKLESSLY-P))) (HANDLER-CASE (PROGN (FORMAT *ERROR-OUTPUT* "~&Roslisp exiting due to condition: ~a~&" CONDITION) (FINISH-OUTPUT *ERROR-OUTPUT*) (FAILURE-QUIT)) (CONDITION NIL (FAILURE-QUIT :RECKLESSLY-P T)))))) (UNLESS (LET ((V (POSIX-GETENV "ROSLISP_BACKTRACE_ON_ERRORS"))) (AND (STRINGP V) (> (LENGTH V) 0))) (SETQ *INVOKE-DEBUGGER-HOOK* #'ROSLISP-DEBUGGER-HOOK))) ;; load file (let ((filename (third sb-ext:*posix-argv*))) (let ((stream (open filename :direction :input)) ;; remove artificial arguments (sb-ext::*posix-argv* (cddr sb-ext::*posix-argv*))) (unwind-protect (progn ;; ignore shebang line (read-line stream) (load stream)) (close stream)))) roslisp-1.9.20/scripts/test-genmsg-lisp000077500000000000000000000016741270365674000201370ustar00rootroot00000000000000#!/usr/bin/env bash set -e if (( $# == 2 )) then PKG=`rospack find $1` FILENAME=$PKG/msg/$2.msg rosrun genmsg_cpp genmsg_lisp $FILENAME rosrun roslisp genmsg_lisp.py $FILENAME NAME="$2.lisp" echo " $NAME" diff -w $PKG/msg/lisp/$1/$NAME $PKG/msg_gen/lisp/$NAME | head -n 50 NAME="_package_$2.lisp" echo " $NAME" diff -w $PKG/msg/lisp/$1/$NAME $PKG/msg_gen/lisp/$NAME | head -n 50 elif (( $# == 1 )) then for p in `rosmsg package $1` do args=`echo $p | tr "/" " "` echo "$p" $0 $args echo "--------------------------------------" done PKG=`rospack find $1` echo "_package.lisp" diff -w $PKG/msg/lisp/$1/_package.lisp $PKG/msg_gen/lisp/_package.lisp | head -n 50 NAME="$1-msg.asd" echo "$NAME" diff -w $PKG/msg/lisp/$1/$NAME $PKG/msg_gen/lisp/$NAME | head -n 50 else echo "Usage: test-genmsg-lisp PKG MSG or test-genmsg-lisp PKG" exit 1 fi roslisp-1.9.20/scripts/test-gensrv-lisp000077500000000000000000000016741270365674000201630ustar00rootroot00000000000000#!/usr/bin/env bash set -e if (( $# == 2 )) then PKG=`rospack find $1` FILENAME=$PKG/srv/$2.srv rosrun genmsg_cpp gensrv_lisp $FILENAME rosrun roslisp genmsg_lisp.py $FILENAME NAME="$2.lisp" echo " $NAME" diff -w $PKG/srv/lisp/$1/$NAME $PKG/srv_gen/lisp/$NAME | head -n 50 NAME="_package_$2.lisp" echo " $NAME" diff -w $PKG/srv/lisp/$1/$NAME $PKG/srv_gen/lisp/$NAME | head -n 50 elif (( $# == 1 )) then for p in `rossrv package $1` do args=`echo $p | tr "/" " "` echo "$p" $0 $args echo "--------------------------------------" done PKG=`rospack find $1` echo "_package.lisp" diff -w $PKG/srv/lisp/$1/_package.lisp $PKG/srv_gen/lisp/_package.lisp | head -n 50 NAME="$1-srv.asd" echo "$NAME" diff -w $PKG/srv/lisp/$1/$NAME $PKG/srv_gen/lisp/$NAME | head -n 50 else echo "Usage: test-gensrv-lisp PKG SRV or test-gensrv-lisp PKG" exit 1 fi roslisp-1.9.20/src/000077500000000000000000000000001270365674000140775ustar00rootroot00000000000000roslisp-1.9.20/src/client.lisp000066400000000000000000000510471270365674000162550ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The operations called by client code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun advertise (topic topic-type &key (latch nil)) "TOPIC is a string naming a ros topic TOPIC-TYPE is either a string that equals the ros datatype of the topic (e.g. robot_msgs/Pose) or the symbol naming the message type in lisp (e.g. 'robot_msgs:) LATCH (defaults to nil). If non-nil, last message sent on this topic will be sent to new subscribers upon connection. Set up things so that publish may now be called with this topic. Also, returns a publication object that can be used instead of the topic name when publishing." (declare (type (or string symbol) topic-type) (string topic)) (ensure-node-is-running) (setq topic-type (lookup-topic-type topic-type)) (with-fully-qualified-name topic (with-recursive-lock (*ros-lock*) (or (gethash topic *publications*) (let ((pub (make-publication :pub-topic-type topic-type :subscriber-connections nil :is-latching latch :last-message nil))) (setf (gethash topic *publications*) pub) (protected-call-to-master ("registerPublisher" topic topic-type *xml-rpc-caller-api*) c (remhash topic *publications*) (roslisp-error "Unable to contact master at ~a for advertising ~a: ~a" *master-uri* topic c)) (ros-debug (roslisp pub) "Advertised ~a of type ~a" topic topic-type) pub))))) (defun unadvertise (topic) (ensure-node-is-running) (with-fully-qualified-name topic (with-recursive-lock (*ros-lock*) (unless (hash-table-has-key *publications* topic) (roslisp-warn "Not publishing on ~a" topic)) (remhash topic *publications*) (protected-call-to-master ("unregisterPublisher" topic *xml-rpc-caller-api*) c (ros-warn (roslisp) "Could not contact master at ~a when unregistering as publisher of ~a during shutdown: ~a" *master-uri* topic c))))) (defmacro make-publisher-msg (pub &rest msg-args) "Convenience function to create a message that fits to a publisher. Uses the type of the publication PUB to make-msg with the MSG-ARGS." `(make-message (pub-topic-type ,pub) ,@msg-args)) (defmacro publish-msg (pub &rest msg-args) "Convenience function that first does make-msg using the type of PUB and MSG-ARGS, then publishes the resulting message on PUB" (let ((p (gensym))) `(let ((,p ,pub)) (publish ,p (make-msg (pub-topic-type ,p) ,@msg-args))))) (defgeneric publish (pub message) (:documentation "PUB is either a publication object returned by advertise, or a string naming a ros topic. MESSAGE is the message object of the appropriate type for this topic.") (:method :before (pub message) (ensure-node-is-running)) (:method ((topic string) message) (declare (type ros-message message)) (with-fully-qualified-name topic (mvbind (publication known) (gethash topic *publications*) (unless known (if (equal topic "/rosout") (error "The topic /rosout was itself unknown") (roslisp-error "Unknown topic ~a" topic))) (publish publication message)))) (:method ((publication publication) message) ;; Latch the message (when (is-latching publication) (setf (last-message publication) message)) ;; Remove closed streams (setf (subscriber-connections publication) (delete-if #'(lambda (sub) (let ((str (subscriber-stream sub))) (or (not (open-stream-p str)) (gethash str *broken-socket-streams*)))) (subscriber-connections publication))) ;; Write message to each stream (let ((num-written 0)) (dolist (sub (subscriber-connections publication) num-written) ;; TODO: TCPROS has been hardcoded in (incf num-written (tcpros-write message (subscriber-stream sub)))) ))) (defun register-service-fn (service-name function service-type) "service-name is a string, and is the ros name of the service. service type is the symbol lisp type of the service (the base name of the .srv file, e.g., 'roslisp_examples:AddTwoInts). Postcondition: the node has set up a callback for calls to this service, and registered it with the master" (declare (string service-name) (function function) (symbol service-type)) (ensure-node-is-running) (with-fully-qualified-name service-name (with-recursive-lock (*ros-lock*) (let ((info (gethash service-name *services*))) (when info (roslisp-error "Cannot create service ~a as it already exists with info ~a" service-name info))) (let ((uri *service-uri*) (req-class (service-request-type service-type))) (setf (gethash service-name *services*) (make-service :callback function :name service-name :ros-type (ros-datatype service-type) :request-ros-type (ros-datatype (service-request-type service-type)) :response-ros-type (ros-datatype (service-response-type service-type)) :request-class req-class :md5 (md5sum req-class))) (protected-call-to-master ("registerService" service-name uri *xml-rpc-caller-api*) c (remhash service-name *services*) (roslisp-error "Socket error ~a when attempting to contact master at ~a for advertising service ~a" c *master-uri* service-name)))))) (defmacro register-service (service-name service-type) "Register service with the given name SERVICE-NAME (a string) of type SERVICE-TYPE (a symbol) with the master. The callback for the service is also a function named SERVICE-TYPE. See also register-service-fn, for if you want to use a function object as the callback." (when (and (listp service-type) (eq 'quote (first service-type))) (setq service-type (second service-type))) `(register-service-fn ,service-name #',service-type ',service-type)) (defmacro def-service-callback (service (&rest args) &body body) "Define a service callback named SERVICE-FN-NAME for service of type SERVICE-TYPE-NAME (a symbol, e.g 'roslisp_examples:AddTwoInts). ARGS is a list of symbols naming particular fields of the service request object which will be available within the body. Within the body, you may also call the function make-response. This will make an instance of the response message type. E.g., to make a response object with field foo=3, (make-response :foo 3). Instead of (SERVICE-FN-NAME SERVICE-TYPE-NAME), you can just specify a symbol SERVICE-NAME, which will then be used as both." (let ((req (gensym)) (response-args (gensym)) (response-type (gensym)) service-type-name service-fn-name) (etypecase service (list (setq service-fn-name (first service) service-type-name (second service))) (symbol (setq service-fn-name service service-type-name service))) `(defun ,service-fn-name (,req) (declare (ignorable ,req)) ;; For the case when the request object is empty (let ((,response-type (service-response-type ',service-type-name))) (with-fields ,args ,req (flet ((make-response (&rest ,response-args) (apply #'make-instance ,response-type ,response-args))) ,@body)))))) (defclass service-client () ((service-client-name :reader service-client-name :initarg :service-client-name :documentation "The name of the service with the ROS master.") (service-client-type :reader service-client-type :initarg :service-client-type :documentation "Type of message sent to request the service."))) (defun make-service-client (service-name service-type) "Convenience function to create service-client object. SERVICE-NAME should be the name of the service at the ROS MASTER, and SERVICE-TYPE is the name of the service message that is send to request the service." (check-type service-name string) (check-type service-type string) (make-instance 'service-client :service-client-name service-name :service-client-type service-type)) (defgeneric call-service (service &rest rest-args)) (defmethod call-service ((service-name string) &rest rest-args) "call-service SERVICE-NAME SERVICE-TYPE &rest ARGS or call-service SERVICE-NAME SERVICE-TYPE REQUEST-OBJECT (happens iff length(ARGS) is 1) SERVICE-NAME - a string that is the ROS name of the service, e.g., my_namespace/my_srv SERVICE-TYPE - symbol or string naming the Lisp type (the basename of the .srv file), e.g. 'AddTwoInts, or the fully qualified type of the service, e.g. \"test_ros/AddTwoInts\" REQUEST-ARGS - initialization arguments that would be used when calling make-instance to create a request object. REQUEST-OBJECT - the request object itself Returns the response object from the service." (destructuring-bind (service-type &rest request-args) rest-args (declare (string service-name) ((or symbol string) service-type)) (ensure-node-is-running) (let* ((service-type (etypecase service-type (symbol service-type) (string (make-service-symbol service-type)))) (response-type (service-response-type service-type))) (with-fully-qualified-name service-name (mvbind (host port) (parse-rosrpc-uri (lookup-service service-name)) ;; No error checking: lookup service should signal an error if there are problems (let ((obj (if (= 1 (length request-args)) (first request-args) (apply #'make-service-request service-type request-args)))) (ros-debug (roslisp call-service) "Calling service at host ~a and port ~a with ~a" host port obj) (tcpros-call-service host port service-name obj response-type))))))) (defmethod call-service ((service service-client) &rest rest-args) "Convenience wrapper of call-service using a service client. Refer to the other call-service for the semantics of the function. SERVICE-CLIENT expects an object of type service-client, though." (apply #'call-service (service-client-name service) (service-client-type service) rest-args)) (defgeneric wait-for-service (service &optional timeout)) (defmethod wait-for-service ((service-name string) &optional timeout) "wait-for-service SERVICE-NAME &optional TIMEOUT Blocks until a service with this name is known to the ROS Master (unlike roscpp, doesn't currently check if the connection is actually valid), then returns true. TIMEOUT, if specified and non-nil, is the maximum (wallclock) time to wait for. If we time out, returns false." (ensure-node-is-running) (let* ((first-time t) (timed-out (nth-value 1 (spin-until (handler-case (progn (lookup-service service-name) t) (ros-rpc-error (c) (declare (ignore c)) nil)) (.1 timeout) (when first-time (setq first-time nil) (ros-debug (roslisp wait-for-service) "Waiting for service ~a" service-name)))))) (ros-debug (roslisp wait-for-service) (not timed-out) "Found service ~a" service-name) (ros-debug (roslisp wait-for-service) timed-out "Timed out waiting for service ~a" service-name) (not timed-out))) (defmethod wait-for-service ((service-client service-client) &optional timeout) "Convenience wrapper of wait-for-service using a service client. Refer to the other wait-for-service for the semantics of the function. SERVICE-CLIENT expects an object of type service-client, though." (wait-for-service (service-client-name service-client) timeout)) (defun subscribe (topic topic-type callback &key (max-queue-length 'infty)) "subscribe TOPIC TOPIC-TYPE CALLBACK &key MAX-QUEUE-LENGTH TOPIC is a string that equals the ros name of the topic TOPIC-TYPE is either a string equalling the ros datatype of the topic, or a symbol naming the lisp type of the messages (see advertise above). CALLBACK is a function of a single argument. MAX-QUEUE-LENGTH is a number. If not provided, it defaults to infinity. Set up subscription to TOPIC with given type. CALLBACK will be called on the received messages in a separate thread. MAX-QUEUE-LENGTH is the number of messages that are allowed to queue up while waiting for CALLBACK to run. Can also be called on a topic that we're already subscribed to - in this case, ignore MAX-QUEUE-LENGTH, and just add this new callback function. It will run in the existing callback thread for the topic, so that at most one callback function can be running at a time." (declare (string topic) (type (or symbol string) topic-type) (function callback)) (ensure-node-is-running) (handler-case (setq topic-type (lookup-topic-type topic-type)) (error (c) (declare (ignore c)) (warn "Couldn't lookup topic type ~a for ~a, so not subscribing." topic-type topic) (return-from subscribe))) (with-fully-qualified-name topic (with-recursive-lock (*ros-lock*) (if (hash-table-has-key *subscriptions* topic) ;; If already subscribed to topic, just add a new callback (let ((sub (gethash topic *subscriptions*))) (unless (equal topic-type (sub-topic-type sub)) (roslisp-error "Asserted topic type ~a for new subscription to ~a did not match existing type ~a" topic-type topic (sub-topic-type sub))) (push callback (callbacks sub)) (make-subscriber :topic topic :subscription sub :callback callback)) ;; Else create a new thread (let ((sub (make-subscription :buffer (make-queue :max-size max-queue-length) :publisher-connections nil :callbacks (list callback) :sub-topic-type topic-type))) (setf (gethash topic *subscriptions*) sub (topic-thread sub) (sb-thread:make-thread (subscriber-thread sub) :name (format nil "Subscriber thread for topic ~a" topic))) (handler-case (progn (update-publishers topic (protected-call-to-master ("registerSubscriber" topic topic-type *xml-rpc-caller-api*) c (roslisp-error "Could not contact master at ~a when registering as subscriber to ~a: ~a" *master-uri* topic c))) (make-subscriber :topic topic :subscription sub :callback callback)) (error (c) (warn "Received error ~a when attempting to setup subscription to ~a of type ~a, so not subscribing." c topic topic-type) (remhash topic *subscriptions*)))))))) (defun unsubscribe (subscriber) (check-type subscriber subscriber) (with-recursive-lock (*ros-lock*) (let ((sub (gethash (subscriber-topic subscriber) *subscriptions*))) (assert sub () (format nil "Subscription to topic `~a' invalid." (subscriber-topic subscriber))) (setf (callbacks sub) (delete (subscriber-callback subscriber) (callbacks sub))) (when (null (callbacks sub)) (protected-call-to-master ("unregisterSubscriber" (subscriber-topic subscriber) *xml-rpc-caller-api*) c (roslisp-error "Could not contact master at ~a when unregistering subscriber to ~a: ~a" *master-uri* (subscriber-topic subscriber) c)) (remhash (subscriber-topic subscriber) *subscriptions*)))) (values)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (declaim (inline ensure-node-is-running)) (defun ensure-node-is-running () (unless (eq *node-status* :running) (cerror "Start a dummy node" "Node status is ~a" *node-status*) (start-ros-node "dummy"))) (defun event-loop () (loop ;; If node has stopped, end loop (unless (eq *node-status* :running) (return)) ;; Allow the tcp server to respond to any incoming connections (handler-bind ((error #'(lambda (c) (with-recursive-lock (*ros-lock*) (unless (eq *node-status* :running) (ros-info (roslisp event-loop) "Event loop received error ~a. Node-status is now ~a" c *node-status*) (return)))))) (sb-sys:serve-all-events 1))) (ros-info (roslisp event-loop) "Terminating ROS Node event loop")) (defun subscriber-thread (sub) "This is the thread that takes items off the queue and performs the callback on them (as separate from the one that puts items onto the queue from the socket)" ;; We don't acquire *ros-lock* - the assumption is that the callback is safe to interleave with the node operations defined in the roslisp package (declare (type subscription sub)) (let ((q (buffer sub))) #'(lambda () (loop (mvbind (item exists) (dequeue-wait q) (unless exists (return)) ;; We have to get this each time because there may be new callbacks (dolist (callback (callbacks sub)) (handler-case (funcall callback item) (error (e) (ros-error (roslisp service tcp) "Error during subscriber callback: '~a' for topic item: ~%~a " e item))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Experimental ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro def-ros-node (name params (&key spin) &body body) (let ((doc-string (if (stringp (first body)) (first body) "")) (body (if (stringp (first body)) (rest body) body))) `(defun ,name () ,doc-string (with-ros-node (,(string-downcase (symbol-name name)) ,@(when spin '(:spin t))) (let ,(mapcar #'(lambda (param) (let ((param-name (concatenate 'string "~" (string-downcase (symbol-name param))))) `(,param (get-param ,param-name)))) params) ,@body))))) (defmacro def-service-call (a service-ros-name &key return-field) "Convenience macro for calls to a service. def-service-call (FN-NAME TYPE-NAME) ROS-NAME &key RETURN-FIELD where FN-NAME and TYPE-NAME are unevaluated symbols, ROS-NAME is a string (evaluated, so doesn't have to be a literal) This means define a function FN-NAME that calls a ros service with the given ros-name, whose lisp type (which is the base name of the .srv file, but may have to be package qualified if you haven't imported it) is TYPE-NAME. The function does a calls the given service using an appropriately typed request object constructed using its arguments. The first argument can also be a symbol NAME (unevaluated), which uses NAME for both FN-NAME and TYPE-NAME If RETURN-FIELD is provided, that field of the response is returned. Otherwise, the entire response is returned." (let ((args (gensym)) (response (gensym)) name service-type) (if (listp a) (setq name (first a) service-type `',(second a)) (setq name a service-type `',a)) `(defun ,name (&rest ,args) (let ((,response (apply #'call-service ,service-ros-name ,service-type ,args))) ,(if return-field `(with-fields (,return-field) ,response ,return-field) response)))))roslisp-1.9.20/src/command-line-args.lisp000066400000000000000000000113411270365674000202650ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defun process-command-line-remappings (l base-name) "Process command line remappings, including the three special cases for remapping the node name, namespace, and setting parameters. Return alist of params to set. Note this is order dependent since setting __ns or __name affects how remappings are interpreted." (setf *remapped-names* (make-hash-table :test #'equal)) (let ((params nil)) (dolist (x l params) (dbind (lhs rhs) x (cond ((equal lhs "__ns") (setf *namespace* (postprocess-namespace rhs) *ros-node-name* (compute-node-name base-name))) ((equal lhs "__name") (setf base-name rhs *ros-node-name* (compute-node-name rhs))) ((equal lhs "__log") (setf *ros-log-location* rhs)) ((eql (char lhs 0) #\_) (push (cons (concatenate 'string "~" (subseq lhs 1)) (let ((rhs-val (read-from-string rhs))) (typecase rhs-val (symbol rhs) (otherwise rhs-val)))) params)) (t (setf (gethash (compute-global-name *namespace* *ros-node-name* lhs) *remapped-names*) (compute-global-name *namespace* *ros-node-name* rhs)))))))) (defun postprocess-namespace (ns) "Ensure that namespace begins and ends with /" (unless (eql (char ns 0) #\/) (setf ns (concatenate 'string "/" ns))) (unless (eql (char ns (1- (length ns))) #\/) (setf ns (concatenate 'string ns "/"))) ns) (defun compute-node-name (name) (concatenate 'string *namespace* (string-trim '(#\/) name))) (defun parse-remapping (string) "If string is of the form FOO:=BAR, return foo and bar, otherwise return nil." (let ((i (search ":=" string))) (when i (values (subseq string 0 i) (subseq string (+ i 2)))))) (defun handle-command-line-arguments (name args) "Postcondition: the variables *remapped-names*, *namespace*, and *ros-node-name* are set based on the argument list and the environment variable ROS_NAMESPACE as per the ros command line protocol. Also, arguments of the form _foo:=bar are interpreted by setting private parameter foo equal to bar (currently bar is just read using the lisp reader; it should eventually use yaml conventions)" (when (stringp args) (setq args (tokens args))) (setq *namespace* (postprocess-namespace (or (sb-ext:posix-getenv "ROS_NAMESPACE") "/")) *ros-node-name* (compute-node-name name)) (let ((remappings (mapcan #'(lambda (s) (mvbind (lhs rhs) (parse-remapping s) (when lhs (list (list lhs rhs))))) args))) (process-command-line-remappings remappings name))) (defun command-line-args-rosout (args params) "Separate function for debug out that's called after the debug levels are set" (ros-debug (roslisp top) "Command line arguments are ~a" args) (ros-info (roslisp top) "Node name is ~a" *ros-node-name*) (ros-info (roslisp top) "Namespace is ~a" *namespace*) (ros-info (roslisp top) "Params are ~a" params) (ros-info (roslisp top) "Remappings are:") (maphash #'(lambda (k v) (ros-info (roslisp top) " ~a = ~a" k v)) *remapped-names*)) roslisp-1.9.20/src/debug-levels.lisp000066400000000000000000000115631270365674000173540ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) ;; We hash from lists to numbers. Could make more efficient using a tree of hashtables instead. (defvar *debug-levels* (make-hash-table :test #'equal)) (defun debug-level-exists (l) (hash-table-has-key *debug-levels* (mapcar #'make-keyword-symbol (reverse l)))) (defun debug-level (name) (or (gethash name *debug-levels*) (if name (debug-level (cdr name)) (level-code :info)))) (defun debug-topic-param (name) (concatenate-ros-names (cons "~debug" (nconc (mapcar #'string-downcase (designated-list name)) (list "level"))))) (defgeneric debug-level-string (level) (:method ((level symbol)) (string-downcase (symbol-name level))) (:method ((level fixnum)) (debug-level-string (car (rassoc level (symbol-codes 'rosgraph_msgs-msg:)))))) (defgeneric level-code (level) (:method ((level fixnum)) level) (:method ((level symbol)) (symbol-code 'rosgraph_msgs-msg: level)) (:method ((level string)) (level-code (find-symbol level :keyword)))) (defun set-local-debug-level (topic level &optional (h *debug-levels*)) (ros-debug (roslisp rosout) "Locally setting debug level of ~a to ~a" topic level) (let ((debug-topic (mapcar #'make-keyword-symbol (reverse topic)))) (setf (gethash debug-topic h) (level-code level)))) (defun set-debug-level (name level) (set-local-debug-level (designated-list name) level *debug-levels*) (when (eq *node-status* :running) (ros-debug (roslisp rosout) "Setting ros parameter for debug level of ~a to ~a" (designated-list name) level) (set-param (debug-topic-param name) (debug-level-string level))) ) (defun set-debug-level-unless-exists (name level) (unless (debug-level-exists name) (set-debug-level name level))) (defmacro set-debug-levels (&rest args) "set-debug-level NAME1 LEVEL1 ... NAMEk LEVELk Each NAME (unevaluated) is a list, e.g. (roslisp tcp) denoting a debugger topic. LEVEL is one of the keyword symbols :debug, :info, :warn, :error, or :fatal." (labels ((helper (args) (when args `((set-debug-level ',(car args) ,(cadr args)) ,@(helper (cddr args)))))) `(progn ,@(helper args)))) (defun is-prefix (s1 s2) (when (<= (length s1) (length s2)) (search s1 s2 :end2 (length s1)))) (defun is-suffix (s1 s2) (let ((l1 (length s1)) (l2 (length s2))) (and (<= l1 l2) (search s1 s2 :start2 (- l2 l1))))) (defun is-debug-level-param (p) (and (is-prefix (fully-qualified-name "~debug") p) (is-suffix "/level" p))) (defun get-debug-topic (p) (let* ((prefix (fully-qualified-name "~debug")) (tokens (tokens p :start (length prefix) :separators '(#\/)))) (subseq tokens 0 (1- (length tokens))))) (def-service-callback (reset-debug-levels Empty) () (dolist (param (list-params "~debug")) (when (is-debug-level-param param) (let ((level (string-upcase (get-param param)))) (if (member level '("DEBUG" "INFO" "WARN" "ERROR" "FATAL") :test #'equal) (set-local-debug-level (get-debug-topic param) level) (ros-warn (roslisp rosout) "Skipping setting debug level of ~a to unknown level ~a" param level))))) (make-response)) roslisp-1.9.20/src/master.lisp000066400000000000000000000073771270365674000163010ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Code for talking to the master over xml rpc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-condition ros-rpc-error () ;; TODO ((code :initarg :code :reader code) (message :initarg :message :reader message) (vals :initarg :vals :reader vals) (call :initarg :call :reader call) (uri :initarg :uri :reader rpc-uri)) (:report (lambda (c str) (format str "ros-rpc call ~a to ~a failed with code ~a, message ~a, values ~a" (call c) (rpc-uri c) (code c) (message c) (vals c))))) (defun lookup-service (name) (ros-rpc-call *master-uri* "lookupService" name)) (defun ros-rpc-call (uri name &rest args) "ros-rpc-call XML-RPC-SERVER-URI CALL-NAME &rest CALL-ARGS. Preprends the ros node name to the arg list and does the call. Throws a continuable error if a code <= 0 is returned. Otherwise, return the values. Requires that uri is not null (though node need not be running)." (mvbind (address port) (parse-uri uri) (dbind (code msg vals) (xml-rpc-call (apply #'encode-xml-rpc-call name (or *ros-node-name* "uninitialized-roslisp-node") args) :host address :port port) (when (<= code 0) (cerror "Ignore and continue" 'ros-rpc-error :call (cons name args) :uri uri :code code :message msg :vals vals)) vals))) (defmacro protected-call-to-master ((&rest args) &optional c &body cleanup-forms) "Wraps an xml-rpc call to the master. Calls cleanup forms if xml-rpc connection fails. Requires that the node is running, or that the *master-uri* is set." (setf c (or c (gensym))) `(handler-case (let ((args (list ,@args))) (assert *master-uri* nil "Master uri not set") (ros-debug (roslisp master) "Calling master with arguments `~a'" args) (apply #'ros-rpc-call *master-uri* args)) (sb-bsd-sockets:connection-refused-error (,c) (declare (ignorable ,c)) ,@cleanup-forms))) roslisp-1.9.20/src/msg-header.lisp000066400000000000000000000061031270365674000170040ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Special case code for message headers ;; Not currently used ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| (defvar *serialize-recursion-level* 0 "Bound during calls to serialize, so we can keep track of when header time stamps need to be filled in") (defvar *seq* 0) (defvar *seq-lock* (make-mutex :name "lock on seq global variable")) ;; not currently used (defvar *set-seq* nil) ;; For now not setting seq fields as doesn't seem to be necessary for ROS (defmethod serialize :around (msg str) ;; Note that each thread has its own copy of the variable (let ((*serialize-recursion-level* (1+ *serialize-recursion-level*))) (call-next-method))) (defmethod serialize :around ((msg rosgraph_msgs-msg:
) str) ;; We save the old stamp for convenience when debugging interactively and reusing the same message object (let ((old-stamp (rosgraph_msgs-msg:stamp msg))) (unwind-protect (progn (when (= *serialize-recursion-level* 1) (when *set-seq* (setf (rosgraph_msgs-msg:seq msg) (incf *seq*))) (when (= (rosgraph_msgs-msg:stamp msg) 0.0) (setf (rosgraph_msgs-msg:stamp msg) (ros-time)))) (call-next-method)) (setf (rosgraph_msgs-msg:stamp msg) old-stamp)))) |#roslisp-1.9.20/src/msg-serialization-stream.lisp000066400000000000000000000054031270365674000217240ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defclass msg-serialization-stream (sb-gray:fundamental-binary-output-stream) ((data-buffer :reader serialized-message) (position :initform 0))) (defmethod initialize-instance :after ((strm msg-serialization-stream) &key buffer-size) (assert buffer-size () "Parameter `buffer-size' not specified") (setf (slot-value strm 'data-buffer) (make-array buffer-size :element-type '(unsigned-byte 8)))) (defmethod stream-element-type ((strm msg-serialization-stream)) (array-element-type (serialized-message strm))) (defmethod sb-gray:stream-file-position ((strm msg-serialization-stream) &optional position) (if position (setf (slot-value strm 'position) position) (slot-value strm 'position))) (defmethod sb-gray:stream-write-byte ((strm msg-serialization-stream) integer) (declare (type (unsigned-byte 8) integer)) (with-slots (data-buffer position) strm (setf (aref data-buffer position) integer) (incf position))) roslisp-1.9.20/src/msg.lisp000066400000000000000000000414211270365674000155600ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package roslisp) (eval-when (:compile-toplevel :load-toplevel :execute) (require 'sb-cltl2)) (defmethod deserialize ((msg symbol) str) (let ((m (make-instance msg))) (deserialize m str) m)) (defmethod md5sum ((msg-type array)) (if (stringp msg-type) (md5sum (get-topic-class-name msg-type)) (progn (warn "Hmmm... unexpected topic type specifier ~a in md5sum. Passing it on anyway..." msg-type) (call-next-method)))) (defmethod ros-datatype ((msg-type array)) (if (stringp msg-type) (ros-datatype (get-topic-class-name msg-type)) (progn (warn "Hmm... unexpected topic type specifier ~a in ros-datatype. Passing it on anyway..." msg-type) (call-next-method)))) (defmethod message-definition ((msg-type array)) (if (stringp msg-type) (message-definition (get-topic-class-name msg-type)) (progn (warn "Hmm... unexpected topic type specifier ~a in message-definition. Passing it on anyway..." msg-type) (call-next-method)))) (defun make-response (service-type &rest args) (apply #'make-instance (service-response-type service-type) args)) (defmethod symbol-codes ((msg-type symbol)) nil) (defmethod symbol-codes ((m ros-message)) (symbol-codes (type-of m))) (defmethod symbol-code ((m ros-message) s) (symbol-code (type-of m) s)) (defmethod code-symbols ((msg-type symbol) code) (remove code (symbol-codes msg-type) :test-not #'= :key #'rest)) (defmethod code-symbols ((m ros-message) code) (code-symbols (type-of m) code)) (defmethod code-symbol ((msg-type symbol) code) (let ((pair (rassoc code (symbol-codes msg-type) :test #'=))) (unless pair (error "Could not get code symbol for ~a in ROS message type ~a" code msg-type)) (car pair))) (defmethod code-symbol ((m ros-message) code) (code-symbol (type-of m) code)) (defmethod symbol-code ((m symbol) s) (let ((pair (assoc s (symbol-codes m)))) (unless pair (error "Could not get symbol code for ~a for ROS message type ~a" s m)) (cdr pair))) (defmethod ros-message-to-list (msg) (check-type msg (not ros-message) "something that is not a ros-message") msg) (defmethod list-to-ros-message ((l null)) ;; Tricky case: nil should be treated as false (i.e. a primitive boolean) rather than the empty list ;; (since a ros message always has at least one element: the message type) nil) (defmethod list-to-ros-message ((l list)) (apply #'make-instance (first l) (mapcan #'(lambda (pair) (list (car pair) (list-to-ros-message (cdr pair)))) (rest l)))) ;; Either a primitive type or vector or already a ros message (should do a bit more type checking) (defmethod list-to-ros-message (msg) msg) (defun convert-to-keyword (s) (declare (symbol s)) (let ((name (string-upcase (symbol-name s)))) (when (> (length name) 4) (let ((pos (- (length name) 4))) (when (search "-VAL" name :start2 pos) (let ((new-name (subseq name 0 pos))) (signal 'compile-warning :msg (format nil "I'm assuming you're using ~a to refer to ~a (the old form), in a call to with-fields or def-service-callback. For now, converting automatically. This usage is deprecated though; switch to just using ~a (cf roslisp_examples/add-two-ints-server.lisp)." name new-name new-name)) (setq s (intern new-name 'keyword))))))) (if (keywordp s) s (intern (symbol-name s) 'keyword))) (defun extract-nested-field (m f) "extract a named field from a message. F can also be a list. E.g, if F is '(:bar :foo) that means extract field foo of field bar of the message. Calls list-to-ros-message before returning." (let ((l (ros-message-to-list m))) (list-to-ros-message (cond ((symbolp f) (get-field l f)) ((null (rest f)) (get-field l (first f))) (t (extract-nested-field (get-field l (first f)) (rest f))))))) (defun get-field (l f) (declare (list l) (symbol f)) (let ((pair (assoc f (rest l)))) (unless pair (error "Could not find field ~a in ~a" f l)) (cdr pair))) (defun set-field (l f v) (declare (list l) (symbol f)) (let ((pair (assoc f (rest l)))) (unless pair (error "Could not find field ~a in ~a" f l)) (setf (cdr pair) v))) (defun msg-slot-symbol (msg slot &optional (pkg (symbol-package (type-of msg)))) "Returns the correct symbol for `slot' that can be used to call SLOT-VALUE on `msg'. `slot' is either a string or a symbol. The return value is a symbol in `msg's package" (declare (type (or string symbol) slot)) (let ((symbol-name (etypecase slot (string (string-upcase slot)) (symbol (symbol-name slot))))) (intern symbol-name pkg))) (defun msg-slot-value (msg slot) "Like slot-value but this function ignores the package of `slot' and infers it by using the package of `msg'" (slot-value msg (msg-slot-symbol msg slot))) (define-compiler-macro msg-slot-value (&whole expr msg slot &environment env) (let ((msg-type (when (symbolp msg) (cdr (assoc 'type (nth-value 2 (sb-cltl2:variable-information msg env))))))) (if (and msg-type (subtypep msg-type 'roslisp-msg-protocol:ros-message)) (let* ((slot-symbol (msg-slot-symbol nil slot (symbol-package msg-type))) (slot-type (msg-slot-type msg-type slot-symbol))) `(the ,slot-type (slot-value ,msg ',slot-symbol))) expr))) (defun msg-slot-type (class-name slot) (let ((class (find-class class-name))) (unless (sb-mop:class-finalized-p class) (sb-mop:finalize-inheritance class)) (let* ((slot-symbol (msg-slot-symbol nil slot (symbol-package class-name))) (slot-definition (find slot-symbol (sb-mop:class-slots class) :key #'sb-mop:slot-definition-name))) (when slot-definition (sb-mop:slot-definition-type slot-definition))))) (defun make-field-reader-with-type (value-sym type field-definition) (if (and type field-definition (subtypep type 'roslisp-msg-protocol:ros-message)) (make-field-reader-with-type `(slot-value ,value-sym ',(msg-slot-symbol nil (car field-definition) (symbol-package type))) (msg-slot-type type (car field-definition)) (cdr field-definition)) value-sym)) (defun make-field-reader (value-sym field-definition) (if field-definition (make-field-reader `(msg-slot-value ,value-sym ',(car field-definition)) (cdr field-definition)) value-sym)) (defun field-reader-type (msg-type field-definition) (when msg-type (if (cdr field-definition) (field-reader-type (msg-slot-type msg-type (car field-definition)) (cdr field-definition)) (msg-slot-type msg-type (car field-definition))))) (defun make-field-definitions (defs msg-sym &optional msg-type) (flet ((make-def (name def) `(,name ,(if msg-type (make-field-reader-with-type msg-sym msg-type def) (make-field-reader msg-sym def))))) (mapcar-with-field-definition #'make-def defs))) (defun mapcar-with-field-definition (function defs) (flet ((ensure-list (x) (if (listp x) x (list x)))) (mapcar (lambda (def) (multiple-value-bind (name def) (if (listp def) (values (first def) (reverse (ensure-list (second def)))) (values def (ensure-list def))) (funcall function name def))) defs))) (defmacro with-fields (bindings msg &body body &environment env) "with-fields BINDINGS MSG &rest BODY A macro for convenient access to message fields. BINDINGS is an unevaluated list of bindings. Each binding is like a let binding (FOO BAR), where FOO is a symbol naming a variable that will be bound to the field value. BAR describes the field. In the simplest case it's just a symbol naming the field. It can also be a list, e.g. (QUX GAR). This means the field QUX of the field GAR of the message. Finally, the entire binding can be a symbol FOO, which is a shorthand for (FOO FOO). MSG evaluates to a message. BODY is the body, surrounded by an implicit progn. As an example, instead of (let ((foo (pkg:foo-val (pkg:bar-val m))) (baz (pkg:baz-val m))) (stuff)) you can use (with-fields ((foo (foo bar)) baz) (stuff)) Efficiency: since the message type of ``m'' may not be known at macroexpansion time, with-fields converts the message to a list at runtime. If, however, the message type is declared, with-fields makes use of the declaration to directly expand to the slot readers. If the message type is not declared, the macro expands to calls to MSG-SLOT-VALUE which needs to infer the correct package at runtime which causes more consing and is less performant." (let ((msg-type (when (symbolp msg) (let ((type (cdr (assoc 'type (nth-value 2 (sb-cltl2:variable-information msg env)))))) (when (symbolp type) type)))) (msg-sym (gensym "MSG"))) (declare (type (or symbol nil) msg-type)) `(let ((,msg-sym ,msg)) (declare (ignorable ,msg-sym)) (let ,(make-field-definitions bindings msg-sym (when (and msg-type (subtypep msg-type 'roslisp-msg-protocol:ros-message)) msg-type)) ,@(when msg-type (mapcar-with-field-definition (lambda (name def) (let ((inferred-msg-type (field-reader-type msg-type def))) (when inferred-msg-type `(declare (type ,inferred-msg-type ,name))))) bindings)) ,@body)))) (defun read-ros-message (stream) (list-to-ros-message (read stream))) (defun field-pair (f l) (let ((p (assoc (intern (symbol-name (car f)) :keyword) (cdr l)))) (assert p nil "Couldn't find field ~a in ~a (overall field spec was ~a)" (car f) (cdr l) f) (if (cdr f) (field-pair (cdr f) (cdr p)) p))) (defun listify-message (m nested-field) (if nested-field (dbind (f . r) nested-field (let ((m2 (ros-message-to-list m))) (set-field m2 f (listify-message (get-field m2 f) r)) m2)) m)) (defun ros-message-to-list-nested (m fields) "Return a copy of M which is sufficiently listified that all the specified fields can be accessed through lists" (dolist (f fields m) (setq m (listify-message m f)))) ;; Basic helper function that takes in a message and returns a new message with some fields updated (see below) (defun set-fields-fn (m &rest args) (let (fields vals) (while args (push (reverse (designated-list (pop args))) fields) (push (pop args) vals)) (let ((l (ros-message-to-list-nested m fields))) (loop for field in fields for val in vals do (setf (cdr (field-pair field l)) val)) (list-to-ros-message l)))) (defun make-message-fn (msg-type &rest args) "Creates a message of ros type MSG-TYPE (a string PKG/MSG), where the odd ARGS are lists of keywords that designated a nested field and the even arguments are the values. E.g., where an odd argument '(:foo :bar) means the foo field of the bar field of the corresponding even argument." (destructuring-bind (pkg-name type) (tokens (string-upcase msg-type) :separators '(#\/)) (let ((pkg (find-package (intern (concatenate 'string pkg-name "-MSG") 'keyword)))) (assert pkg nil "Can't find package ~a-MSG" pkg-name) (let ((class-name (find-symbol type pkg))) (assert class-name nil "Can't find class for ~a" msg-type) (apply #'set-fields-fn (make-instance class-name) args))))) (defun make-service-request-fn (srv-type &rest args) (destructuring-bind (pkg type) (tokens (string-upcase srv-type) :separators '(#\/)) (let ((pkg (find-package (intern (concatenate 'string pkg "-SRV") 'keyword)))) (assert pkg nil "Can't find package ~a" pkg) (let ((class-name (find-symbol (concatenate 'string type "-REQUEST") pkg))) (assert class-name nil "Can't find class ~a in package ~a" class-name pkg) (apply #'set-fields-fn (make-instance class-name) args))))) (defmacro make-request (srv-type &rest args) "make-request SRV-TYPE &rest ARGS Like make-message, but creates a service request object. SRV-TYPE can be either a string of the form package_name/message_name, or a symbol naming the service (the name is the base name of the .srv file). ARGS are as in make-message." (etypecase srv-type (string `(make-service-request-fn ,srv-type ,@(loop for i from 0 for arg in args collect (if (evenp i) `',arg arg)))) (symbol `(make-service-request ',srv-type ,@args)) (cons (assert (eql (car srv-type) 'quote)) `(make-service-request ,srv-type ,@args)))) (defun make-service-request (service-type &rest args) (apply #'make-instance (service-request-type service-type) args)) (defmacro modify-message-copy (m &rest args) "modify-message-copy MSG &rest ARGS Return a new message that is a copy of MSG with some fields modified. ARGS is a list of the form FIELD-SPEC1 VAL1 ... FIELD-SPEC_k VAL_k as in make-message." `(set-fields-fn ,m ,@(loop for i from 0 for arg in args collect (if (evenp i) `',(mapcar #'convert-to-keyword (designated-list arg)) arg)))) (defmacro setf-msg (place &rest args) "Sets PLACE to be the result of calling modify-message-copy on PLACE and ARGS" (let ((m (gensym))) `(let ((,m ,place)) (setf ,place (modify-message-copy ,m ,@args))))) (defun pairs (l) (when l (assert (rest l)) (cons (list (first l) (second l)) (pairs (nthcdr 2 l))))) (defmacro make-message (msg-type &rest args) "make-message MSG-TYPE &rest ARGS Convenience macro for creating messages easily. MSG-TYPE is a string naming a message ros datatype, i.e.., of form package_name/message_name ARGS is a list of form FIELD-SPEC1 VAL1 ... FIELD-SPECk VALk Each FIELD-SPEC (unevaluated) is a list (or a symbol, which designates a list of one element) that refers to a possibly nested field. VAL is the corresponding value. For example, if MSG-TYPE is the string robot_msgs/Pose, and ARGS are (x position) 42 (w orientation) 1 this will create a Pose with the x field of position equal to 42 and the w field of orientation equal to 1 (other fields equal their default values). For convenience, the field specifiers don't have to actually belong to the message package. E.g., they can be keywords. " `(make-message-fn ,msg-type ,@(loop for i from 0 for arg in args collect (if (evenp i) `',(mapcar #'convert-to-keyword (designated-list arg)) arg)))) (defmacro make-msg (&rest args) "Alias for make-message" `(make-message ,@args)) roslisp-1.9.20/src/namespace.lisp000066400000000000000000000053551270365674000167340ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defun concatenate-ros-names (names) "Takes a list of strings and returns a single string with the names delimited by /'s" (declare (cons names)) (format nil "~a~{/~a~}" (first names) (rest names))) (defun fully-qualified-name (name) "Do the translation from a client-code-specified name to a fully qualified one. Handles already-fully-qualified names, tilde for private namespace, unqualified names, and remapped names." (let ((global-name (compute-global-name *namespace* *ros-node-name* name))) (if *remapped-names* (gethash global-name *remapped-names* global-name) global-name ))) (defun compute-global-name (ns node-global-name name) (case (char name 0) (#\/ name) (#\~ (concatenate 'string node-global-name "/" (subseq name 1))) (otherwise (concatenate 'string ns name)))) (defmacro with-fully-qualified-name (n &body body) (assert (symbolp n)) `(let ((,n (fully-qualified-name ,n))) ,@body)) roslisp-1.9.20/src/node.lisp000066400000000000000000000300071270365674000157150ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defun start-ros-node (name &key (xml-rpc-port 8001 xml-port-supp) (pub-server-port 7001 pub-port-supp) (master-uri (make-uri "127.0.0.1" 11311) master-supplied) (anonymous nil) (cmd-line-args (rest sb-ext:*posix-argv*)) &allow-other-keys) "Start up the ROS Node with the given name and master URI. Reset any stored state left over from previous invocations. MASTER-URI is either a string of the form http://foo:12345, or an object created using make-uri. If MASTER-URI is not provided, use *default-master-uri*, and if that's nil (which it will be unless client code sets it), use the value of environment variable ROS_MASTER_URI. ANONYMOUS, if non-nil, causes the current time to be appended to the node name (to make it unique). XML-RPC-PORT and PUB-SERVER-PORT are no longer used. CMD-LINE-ARGS is the list of command line arguments (defaults to argv minus its first element). It can also be a string of space-separated arguments." (declare (string name) (type (or string uri) master-uri)) (assert (not xml-port-supp) nil "start-ros-node no longer accepts the xml-rpc-port argument") (assert (not pub-port-supp) nil "start-ros-node no longer accepts the pub-server-port argument") (unless (eq *node-status* :shutdown) (warn "Before starting node, node-status equalled ~a instead of :shutdown. Shutting the previous node invocation down now." *node-status*) (shutdown-ros-node)) (when anonymous (mvbind (success s ms) (sb-unix:unix-gettimeofday) (declare (ignore success)) (setq name (format nil "~a_~a_~a" name ms s)))) (let ((params (handle-command-line-arguments name cmd-line-args))) (setq *ros-log-location* (get-ros-log-location name)) (ensure-directories-exist *ros-log-location* :verbose nil) (setq *ros-log-stream* (open *ros-log-location* :direction :output :if-exists :overwrite :if-does-not-exist :create)) ;; Deal with the master uri (unless master-supplied (setq master-uri (or *default-master-uri* (sb-ext:posix-getenv "ROS_MASTER_URI"))) (unless (and (stringp master-uri) (> (length master-uri) 0)) (error "Master uri needs to be supplied either as an argument to start-ros-node, or through the environment variable ROS_MASTER_URI, or by setting the lisp variable *default-master-uri*"))) (when (stringp master-uri) (mvbind (address port) (parse-uri master-uri) (setq master-uri (make-uri address port)))) (symbol-macrolet ((address (uri-address master-uri))) (unless (parse-string-ip-address address) (setf address (ip-address-string (lookup-hostname-ip-address address))))) (setq *master-uri* master-uri) ;; Set params specified at command line (dolist (p params) (set-param (car p) (cdr p))) ;; Initialize debug levels (reset-debug-levels (make-instance 'Empty-Request)) ;; Now we can finally print some debug messages (ros-debug (roslisp top) "Log location is ~a" *ros-log-location*) (command-line-args-rosout cmd-line-args params) (unless master-supplied (ros-debug (roslisp top) "Master uri was not supplied, so using default")) (ros-info (roslisp top) "master URI is ~a:~a" (uri-address master-uri) (uri-port master-uri)) ;; Done setting up master connection ;; Spawn a thread that will start up the listeners, then run the event loop (with-recursive-lock (*ros-lock*) (setf *event-loop-thread* (sb-thread:make-thread #'(lambda () (when (eq *node-status* :running) (error "Can't start node as status already equals running. Call shutdown-ros-node first.")) ;; Start publication and xml-rpc servers. (mvbind (srv sock) (start-xml-rpc-server :port 0) (setq *xml-server* srv xml-rpc-port (nth-value 1 (sb-bsd-sockets:socket-name sock)))) (ros-debug (roslisp top) "Started XML-RPC server on port ~a" xml-rpc-port) (setq *tcp-server-hostname* (hostname) *tcp-server* (ros-node-tcp-server 0) pub-server-port (nth-value 1 (sb-bsd-sockets:socket-name *tcp-server*))) (ros-debug (roslisp top) "Started tcpros server on port ~a" pub-server-port) (setq *tcp-server-port* pub-server-port *broken-socket-streams* (make-hash-table :test #'eq) *service-uri* (format nil "rosrpc://~a:~a" *tcp-server-hostname* *tcp-server-port*) *xml-rpc-caller-api* (format nil "http://~a:~a" (hostname) xml-rpc-port) *publications* (make-hash-table :test #'equal) *subscriptions* (make-hash-table :test #'equal) *services* (make-hash-table :test #'equal) *node-status* :running *deserialization-threads* nil ) (pushnew #'maybe-shutdown-ros-node sb-ext:*exit-hooks*) ;; Finally, start the serve-event loop (event-loop)) :name "ROSLisp event loop")) ;; There's no race condition - if this test and the following advertise call all happen before the event-loop starts, ;; things will just queue up (spin-until (eq *node-status* :running) 1)) ;; Advertise on global rosout topic for debugging messages (advertise "/rosout" "rosgraph_msgs/Log") ;; Subscribe to time if necessary (setq *use-sim-time* (member (get-param "/use_sim_time" nil) '("true" 1 t) :test #'equal)) (when *use-sim-time* (setq *last-clock* nil) (subscribe "/clock" "rosgraph_msgs/Clock" #'(lambda (m) (setq *last-clock* m)) :max-queue-length 5)) ;; Advertise reset-debug-levels service (register-service-fn "~reset_debug_levels" #'reset-debug-levels 'Empty) (ros-info (roslisp top) "Node startup complete"))) (defmacro with-ros-node (args &rest body) "with-ros-node ARGS &rest BODY. Call start-ros-node with argument list ARGS, then execute the body. Takes care of shutting down the ROS node if the body terminates or is interrupted. In addition to the start-ros-node arguments, ARGS may also include the boolean argument :spin. If this is true, after body is executed, the node will just spin forever. Assuming spin is not true, this call will return the return value of the final statement of body." (dbind (name &rest a &key spin &allow-other-keys) args (declare (ignorable name a)) `(let (*namespace*) ;; Set up a binding so that start-ros-node can set it and this will be seen in the body, but not by our caller (unwind-protect (restart-case (progn (start-ros-node ,@args) ,@body ,@(when spin `((spin-until nil 100)))) (shutdown-ros-node (&optional a) (ros-info (roslisp top) "About to shutdown~:[~; due to condition ~:*~a~]" a))) (shutdown-ros-node))))) (defun shutdown-ros-node () "Shutdown-ros-node. Set the status to shutdown, close all open sockets and XML-RPC servers, and unregister all publications, subscriptions, and services with master node. Finally, if *running-from-command-line* is true, exit lisp." (ros-debug (roslisp top) "Acquiring lock") (with-recursive-lock (*ros-lock*) (unless (eq *node-status* :shutdown) (ros-debug (roslisp top) "Initiating shutdown") (setf *node-status* :shutdown) (handler-case (stop-server *xml-server*) (error (c) (cerror "Continue" "Error stopping xml-rpc server: ~a" c))) (close-socket *tcp-server*) ;; Unregister from publications and subscriptions and close the sockets and kill callback and deserialization threads (do-hash (topic pub *publications*) (protected-call-to-master ("unregisterPublisher" topic *xml-rpc-caller-api*) c (ros-warn (roslisp) "Could not contact master at ~a when unregistering as publisher of ~a during shutdown: ~a" *master-uri* topic c)) (dolist (sub (subscriber-connections pub)) (handler-case (close-socket (subscriber-socket sub)) (sb-int:simple-stream-error (c) (ros-debug (roslisp top) "Received stream error ~a when attempting to close socket ~a. Skipping." c (subscriber-socket sub)))))) (do-hash (topic sub *subscriptions*) (protected-call-to-master ("unregisterSubscriber" topic *xml-rpc-caller-api*) c (ros-warn (roslisp) "Could not contact master when unsubscribing from ~a during shutdown: ~a" topic c)) (handler-case (terminate-thread (topic-thread sub)) (interrupt-thread-error (e) (declare (ignore e))))) (dolist (thread *deserialization-threads*) (ros-debug (roslisp deserialization-thread) "Killing deserialization thread") (ignore-errors (terminate-thread thread))) ;; Unregister services (do-hash (name s *services*) (let ((i (protected-call-to-master ("unregisterService" name *service-uri*) c (ros-warn roslisp "During shutdown, unable to contact master to unregister service ~a: ~a" name c) 1))) (unless (eql i 1) (ros-warn (roslisp top) "When trying to close service ~a, ~a services were closed instead of 1" name i)))) ;; Unset variables that will be used upon next startup (setq *ros-log-location* nil) ;; wait nicely for end of event loop, which was notified by setting *node-status* to shutdown (dotimes (wait-it 6) (when (sb-thread:thread-alive-p *event-loop-thread*) (sleep 0.5))) (when (sb-thread:thread-alive-p *event-loop-thread*) ;; try killing event-loop thread (may take time) (sb-thread:terminate-thread *event-loop-thread*) (dotimes (wait-it 6) (when (sb-thread:thread-alive-p *event-loop-thread*) (sleep 0.5)))) (when (sb-thread:thread-alive-p *event-loop-thread*) (error "Event-loop thread cannot be terminated")) (setf *event-loop-thread* nil) (ros-info (roslisp top) "Shutdown complete") (close *ros-log-stream*) (when *running-from-command-line* (sb-ext:exit))))) (defun maybe-shutdown-ros-node () (unless (eq *node-status* :shutdown) (shutdown-ros-node))) roslisp-1.9.20/src/params.lisp000066400000000000000000000104011270365674000162470ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defun get-param (key &optional (default nil default-supplied)) "get-param KEY &optional DEFAULT. KEY is a string naming a ros parameter. Looks up parameter on parameter server. If not found, use default if provided, and error otherwise." (declare (string key)) (with-fully-qualified-name key (if (has-param key) (protected-call-to-master ("getParam" key) c (roslisp-error "Could not contact master when getting param ~a: ~a" key c)) (if default-supplied default (roslisp-error "Param ~a does not exist, and no default supplied" key))))) (defun set-param (key val) "set-param KEY VAL KEY is a string naming a ros parameter. VAL is a string or integer. Post: parameter key set to value on the parameter server." (declare (string key)) (with-fully-qualified-name key (protected-call-to-master ("setParam" key val) c (roslisp-error "Could not contact master at ~a when setting param ~a" *master-uri* key)))) (defun has-param (key) "KEY is a string naming a ros parameter Return true iff this parameter exists on the server." (declare (string key)) (with-fully-qualified-name key (protected-call-to-master ("hasParam" key) c (roslisp-error "Could not contact master at ~a for call to hasParam ~a: ~a" *master-uri* key c)))) (defun delete-param (key) "KEY is a string naming a ros parameter Remove this key from parameter server." (declare (string key)) (with-fully-qualified-name key (protected-call-to-master ("deleteParam" key) c (roslisp-error "Could not contact master at ~a when deleting param ~a: ~a" *master-uri* key c)))) (defun get-param-names () "Return list of params on server" (protected-call-to-master ("getParamNames") c (roslisp-error "Could not contact master at ~a when getting param list: ~a" *master-uri* c))) (defun list-params (&optional namespace) "NAMESPACE is either a list of symbols (e.g. '(foo bar) refers to /foo/bar) or a string that is treated as a namespace name (possibly relative to the current one). Returns all parameters in that namespace." (declare (type (or string list) namespace)) (setq namespace (if (listp namespace) (format nil "~{/~a~}/" (mapcar #'(lambda (n) (string-downcase (symbol-name n))) namespace)) (let ((fqn (fully-qualified-name namespace))) (if (eql #\/ (char fqn (1- (length fqn)))) fqn (concatenate 'string fqn "/"))))) (filter #'(lambda (name) (search namespace name :end2 (min (length namespace) (length name)))) (get-param-names)))roslisp-1.9.20/src/persistent-service.lisp000066400000000000000000000112641270365674000206320ustar00rootroot00000000000000;;; Copyright (c) 2012, Lorenz Moesenlechner ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions are met: ;;; ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * Redistributions in binary form must reproduce the above copyright ;;; notice, this list of conditions and the following disclaimer in the ;;; documentation and/or other materials provided with the distribution. ;;; * Neither the name of the Intelligent Autonomous Systems Group/ ;;; Technische Universitaet Muenchen nor the names of its contributors ;;; may be used to endorse or promote products derived from this software ;;; without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ;;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;;; POSSIBILITY OF SUCH DAMAGE. (in-package :roslisp) (defclass persistent-service () ((stream :reader persistent-service-stream) (socket :reader persistent-service-socket) (request-type :reader persistent-service-request-type) (response-type :reader persistent-service-response-type) (service-name :initarg :service-name) (service-type :initarg :service-type) (lock :reader persistent-service-lock :initform (sb-thread:make-mutex :name (symbol-name (gensym "PERSISTENT-SERVICE-LOCK")))))) (defgeneric call-persistent-service (service &rest request) (:method ((service persistent-service) &rest request) (with-slots (stream socket request-type response-type lock) service (block nil (loop do (restart-case (sb-thread:with-mutex (lock) (cond ((and (eql (length request) 1) (typep (car request) request-type)) (return (tcpros-do-service-request stream (car request) response-type))) (t (return (tcpros-do-service-request stream (apply #'make-instance request-type request) response-type))))) (reconnect () :report "Try reconnecting persistent service and execute the call again." (close-persistent-service service) (establish-persistent-service-connection service)))))))) (defgeneric close-persistent-service (persistent-service) (:method ((service persistent-service)) (close (persistent-service-stream service) :abort t))) (defgeneric persistent-service-ok (persistent-service) (:documentation "Returns T if the service is still ok, i.e. can be called, NIL otherwise.") (:method ((service persistent-service)) (with-slots (socket) service (and socket (socket-open-p socket))))) (defgeneric establish-persistent-service-connection (service) (:method ((service persistent-service)) (with-slots (service-name service-type stream socket request-type response-type) service (let* ((service-type (etypecase service-type (symbol service-type) (string (make-service-symbol service-type))))) (with-fully-qualified-name service-name (multiple-value-bind (host port) (parse-rosrpc-uri (lookup-service service-name)) (multiple-value-bind (service-stream service-socket) (tcpros-establish-service-connection host port service-name (service-request-type service-type) t) (setf stream service-stream) (setf socket service-socket) (setf request-type (service-request-type service-type)) (setf response-type (service-response-type service-type))))))))) (defmethod initialize-instance :after ((service persistent-service) &key) (establish-persistent-service-connection service)) roslisp-1.9.20/src/pprint.lisp000066400000000000000000000063151270365674000163110ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defun pprint-ros-message (&rest args &aux str m) (if (= (length args) 1) (setf str t m (first args)) (setf str (first args) m (second args))) (pprint-logical-block (str nil :prefix "[" :suffix "]") (let ((l (ros-message-to-list m))) (write (first l) :stream str) (dolist (f (rest l)) (format str "~:@_ ~a:~:@_ ~w" (car f) (ros-message-to-list (cdr f)))))) ) (set-pprint-dispatch 'ros-message #'pprint-ros-message) (defun pprint-hash (&rest args) (bind-pprint-args (s h) args (etypecase h (roslisp-utils::gen-hash-table (pprint-hash s (roslisp-utils::gen-hash-table-table h))) (hash-table (pprint-logical-block (s (roslisp-utils::hash-keys h) :prefix "[" :suffix (let ((not-shown (if *print-length* (max 0 (- (hash-table-count h) *print-length*)) 0))) (if (> not-shown 0) (format nil " and ~R other item~:*~P not shown here.]" not-shown) "]"))) (when (> (roslisp-utils::hash-table-count* h) 0) (loop (let ((k (pprint-pop))) (format s "~a : ~a" k (gethash k h)) (pprint-exit-if-list-exhausted) (pprint-newline :mandatory s))))) (values))))) (defun print-debug-levels () (let ((h (make-hash-table))) (loop for k being each hash-key in *debug-levels* do (setf (gethash k h) (string-upcase (debug-level-string (gethash k *debug-levels*))))) (pprint-hash h))) roslisp-1.9.20/src/roslisp.asd000066400000000000000000000027411270365674000162670ustar00rootroot00000000000000;;;; -*- Mode: LISP -*- (in-package :asdf) (defsystem :roslisp :name "roslisp" :components ((:file "roslisp") (:file "rosutils" :depends-on ("roslisp")) (:file "master" :depends-on ("rosutils")) (:file "rosout-codegen" :depends-on ("msg" "rosutils")) (:file "rosout" :depends-on ("rosout-codegen")) (:file "time" :depends-on ("rosutils" "rosout")) (:file "namespace" :depends-on ("roslisp")) (:file "msg" :depends-on ("roslisp" "rosutils")) (:file "msg-header" :depends-on ("msg" "rosout" "time")) (:file "params" :depends-on ("namespace" "rosutils" "roslisp" "rosout" "master")) (:file "tcpros" :depends-on ("roslisp" "msg" "rosout" "msg-serialization-stream")) (:file "sockets" :depends-on ("roslisp" "rosout")) (:file "slave" :depends-on ("sockets" "tcpros" "rosout")) (:file "command-line-args" :depends-on ("roslisp" "rosout" "namespace")) (:file "client" :depends-on ("sockets" "namespace" "command-line-args" "msg" "rosout" "master")) (:file "persistent-service" :depends-on ("sockets" "namespace" "roslisp" "tcpros")) (:file "debug-levels" :depends-on ("params" "client" "rosout")) (:file "node" :depends-on ("client")) (:file "msg-serialization-stream" :depends-on ("roslisp")) (:file "pprint" :depends-on ("rosout" "msg")) ) :depends-on (:s-xml :s-xml-rpc :sb-bsd-sockets :rosgraph_msgs-msg :roslisp-msg-protocol :ros-load-manifest :roslisp-utils :std_srvs-srv)) ;;;; eof roslisp-1.9.20/src/roslisp.lisp000066400000000000000000000200661270365674000164670ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :roslisp (:use :cl :sb-bsd-sockets :sb-sys :sb-thread :s-xml-rpc :roslisp-extended-reals :roslisp-queue :roslisp-utils :roslisp-msg-protocol :ros-load-manifest :std_srvs-srv ) (:export :msg-slot-value :with-fields :make-message :make-msg :modify-message-copy :setf-msg :ros-message :node-status :make-response :make-request :symbol-code :symbol-codes :code-symbols :code-symbol :load-if-necessary :*current-ros-package* :start-ros-node :shutdown-ros-node :with-ros-node :def-ros-node :print-status :make-response :defservice :advertise :unadvertise :subscribe :unsubscribe :register-service :register-service-fn :service-error :service-call-error :def-service-callback :call-service :wait-for-service :def-service-call :make-service-client :publish :publish-msg :make-publisher-msg :loop-at-most-every :spin-until :wait-duration :with-parallel-thread :store-message-in :load-message-types :load-service-types :get-param :set-param :has-param :delete-param :list-params :ros-time :ros-time-not-yet-received :spin-until-ros-time-valid :pprint-ros-message :read-ros-message :set-debug-level :set-debug-levels :print-debug-levels :debug-level :ros-debug :ros-warn :ros-info :ros-error :ros-fatal ;; debug topics :roslisp :top :tcp :load-msg ;; todo remove? :load-srv ;; todo remove? :*ros-node-name* :num-subscribers :fully-qualified-name :make-uri :*default-master-uri* :*master-uri* :standalone-exec-debug-hook :*running-from-command-line* :persistent-service :call-persistent-service :reconnect :close-persistent-service :persistent-service-ok)) (in-package :roslisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ROS Node state ;; Stored in special variables since node is a singleton ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar *ros-node-name* nil "String holding node global name") (defvar *node-status* :shutdown) (defvar *event-loop-thread* nil "Handle to thread for killing") (defvar *master-uri* nil "URI of ROS master") (defvar *default-master-uri* nil "Default master URI. Is nil (intended for convenience during interactive use).") (defvar *xml-server* nil "String holding name of XML-RPC server (needed by s-xml-rpc") (defvar *xml-rpc-caller-api* nil "Holds the caller-api argument to XML RPC calls to the master.") (defvar *tcp-server* nil "Passive socket that topic-subscribers will connect to") (defvar *tcp-server-hostname* nil "Address of tcp server") (defvar *tcp-server-port* nil "Port of tcp server") (defvar *service-uri* nil "uri for service calls to this node") (defvar *publications* nil "Hashtable from topic name to list of subscriber-connections") (defvar *subscriptions* nil "Hashtable from topic name to object of type subscription") (defvar *services* nil "Hashtable from service name to object of type service") (defvar *ros-lock* (make-mutex :name "API-wide lock for all operations that affect/are affected by state of node")) (defvar *debug-stream-lock* (make-mutex :name "API-wide lock for the debugging output stream.")) (defvar *running-from-command-line* nil "True iff running ROS node script from command line (noninteractively)") (defvar *broken-socket-streams* nil "Used by TCPROS to keep track of sockets that have died and shouldn't be written to any more.") (defvar *namespace* "/" "Dynamic variable that holds the current namespace. Bound when node starts, and by in-namespace") (defvar *ros-log-location* nil "Name of file to which ros lisp debugging info is written") (defvar *ros-log-stream* nil "Output stream bound to log file during node execution") (defvar *remapped-names* nil "Hash from strings to strings containing names that have been remapped on the command line") (defvar *debug-stream* t "Stream to which to print debug messages. Defaults to standard out.") (defvar *break-on-socket-errors* nil "If true, then any error on a socket will cause a (continuable) break") (defvar *debug-level* 2 "Controls the behavior of ros-debug and others. The default value of 2 means print info and above. 1 would be everything. 4 would be warnings and above, etc.") (defvar *last-clock* nil) (defvar *use-sim-time* nil) (defvar *deserialization-threads* nil "List of threads that deserialize messages from sockets into topic queues. These have to be terminated explicitly when we shutdown (because they may be stuck in a blocking read).") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Type defs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; TODO is this all that goes in a URI - Should the protocol name be included? ;: Note other code assumes URI's can be tested for equality using #'equalp (defstruct (uri (:constructor create-uri)) address port) (defun make-uri (address port) (create-uri :address address :port port)) (defstruct (subscription (:conc-name nil)) sub-topic-type buffer topic-thread (callbacks nil) publisher-connections) (defstruct subscriber topic subscription callback) (defstruct (publisher-connection (:conc-name nil)) publisher-socket publisher-stream uri) (defstruct (publication (:conc-name nil)) pub-topic-type subscriber-connections is-latching last-message) (defstruct (subscriber-connection (:conc-name nil)) subscriber-socket subscriber-stream subscriber-uri) (defstruct service md5 name ros-type request-ros-type response-ros-type request-class callback) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Querying the node ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun node-status () *node-status*) (defun num-subscribers (pub) (length (subscriber-connections pub))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Debugging ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun print-status () (format t "~&Node ~a~2I~&status: ~a~&Master URI: ~a~&Publications ~/roslisp-utils:pprint-hash/~&Subscriptions ~/roslisp-utils:pprint-hash/" *ros-node-name* *node-status* *master-uri* *publications* *subscriptions*)) (define-condition compile-warning (condition) ((msg :initarg :msg))) roslisp-1.9.20/src/rosout-codegen.lisp000066400000000000000000000064321270365674000177320ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; code generation for rosout ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun designated-list (x) (if (listp x) x (list x))) (defgeneric make-keyword-symbol (s) (:method ((s symbol)) (intern (string-upcase (symbol-name s)) :keyword)) (:method ((s string)) (intern (string-upcase s) :keyword))) (defun can-write-to-log () (and *ros-log-stream* (open-stream-p *ros-log-stream*))) (defun rosout-msg (name level args) (let ((code (symbol-code 'rosgraph_msgs-msg:Log level))) (when (typep (first args) 'string) (push t args)) (dbind (check str &rest format-args) args (let ((output-string (gensym))) `(when (and (>= ,code (debug-level ',(reverse (mapcar #'make-keyword-symbol (if (listp name) name (list name)))))) ,check) (let ((,output-string (format nil ,str ,@format-args))) (with-mutex (*debug-stream-lock*) (format *debug-stream* "~&[~a ~a] ~,3F: ~a~&" ',(designated-list name) ,level (ros-time) ,output-string) (when (can-write-to-log) (format *ros-log-stream* "~&[~a ~a] ~,3F: ~a~&" ',(designated-list name) ,level (ros-time) ,output-string))) (force-output *debug-stream*) (when (can-write-to-log) (force-output *ros-log-stream*)) (when (and (eq *node-status* :running) (gethash "/rosout" *publications*)) (publish "/rosout" (make-instance 'rosgraph_msgs-msg:Log :name *ros-node-name* :level ,code :msg ,output-string))))))))) roslisp-1.9.20/src/rosout.lisp000066400000000000000000000111631270365674000163250ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Called by user ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro ros-debug (name &rest args) "ros-debug NAME [CONDITION] FORMAT-STRING . ARGS When CONDITION is true, and the debug level of debug topic NAME is at least :debug, output the given format string and arguments to stdout and publish on rosout if possible. Otherwise do nothing; in particular, don't evaluate the ARGS. CONDITION can be omitted if the FORMAT-STRING is a literal string, in which case it defaults to t." (rosout-msg name :debug args)) (defmacro ros-info (name &rest args) "ros-info NAME [CONDITION] FORMAT-STRING . ARGS When CONDITION is true, and the debug level of debug topic NAME is at least :info, output the given format string and arguments to stdout and publish on rosout if possible. Otherwise do nothing; in particular, don't evaluate the ARGS. CONDITION can be omitted if the FORMAT-STRING is a literal string, in which case it defaults to t." (rosout-msg name :info args)) (defmacro ros-warn (name &rest args) "ros-warn NAME [CONDITION] FORMAT-STRING . ARGS When CONDITION is true, and the debug level of debug topic NAME is at least :warn, output the given format string and arguments to stdout and publish on rosout if possible. Otherwise do nothing; in particular, don't evaluate the ARGS. CONDITION can be omitted if the FORMAT-STRING is a literal string, in which case it defaults to t." (rosout-msg name :warn args)) (defmacro ros-error (name &rest args) "ros-error NAME [CONDITION] FORMAT-STRING . ARGS When CONDITION is true, and the debug level of debug topic NAME is at least :error, output the given format string and arguments to stdout and publish on rosout if possible. Otherwise do nothing; in particular, don't evaluate the ARGS. CONDITION can be omitted if the FORMAT-STRING is a literal string, in which case it defaults to t." (rosout-msg name :error args)) (defmacro ros-fatal (name &rest args) "ros-fatal NAME [CONDITION] FORMAT-STRING . ARGS When CONDITION is true, and the debug level of debug topic NAME is at least :fatal, output the given format string and arguments to stdout and publish on rosout if possible. Otherwise do nothing; in particular, don't evaluate the ARGS. CONDITION can be omitted if the FORMAT-STRING is a literal string, in which case it defaults to t." (rosout-msg name :fatal args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Some standard errors that can be declared now that ;; the macros are defined ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod serialization-length ((msg t)) (ros-error roslisp "Hmm... unexpectedly asked for serialization length of ~w. Most likely because the aforementioned object was found some place where a (nonprimitive) ros message was expected." msg) 42) roslisp-1.9.20/src/rosutils.lisp000066400000000000000000000265331270365674000166650ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package roslisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ROSLisp-specific utility code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-condition function-timeout (error) ()) (defun with-function-timeout (expires body-fun) "throws function-timeout error when call takes longer than expires arg" (flet ((timeout-fun () (error 'function-timeout))) (let ((timer (sb-ext:make-timer #'timeout-fun))) (sb-ext:schedule-timer timer expires) (unwind-protect (funcall body-fun) (sb-ext:unschedule-timer timer))))) (defun get-ros-log-location (name) ;; Tries various possibilities in order of decreasing priority (let ((log-dir (sb-ext:posix-getenv "ROS_LOG_DIR")) (ros-home-dir (sb-ext:posix-getenv "ROS_HOME")) (home-dir (sb-ext:posix-getenv "HOME"))) (or *ros-log-location* (merge-pathnames (pathname (format nil "~a-~a.log" (if (eql (aref name 0) #\/) (subseq name 1) name) (unix-time))) (or (when log-dir (concatenate 'string log-dir "/")) (when ros-home-dir (concatenate 'string ros-home-dir "/log/")) (when home-dir (concatenate 'string home-dir "/.ros/log/")) (error "None of the possibilities for the log directory worked. Even the HOME environment variable was not set.")))))) (defun parse-uri (uri) "parse a uri struct or uri string of the form http://address:port. Return two values: address and port." (etypecase uri (string (let ((tokens (tokens uri :separators (list #\: #\/)))) (unless (and (= (length tokens) 3) (string= (first tokens) "http")) (error "Malformed URI ~a" uri)) (values (second tokens) (read-from-string (third tokens))))) (uri (values (uri-address uri) (uri-port uri))))) (defun parse-rosrpc-uri (uri) (let ((tokens (tokens uri :separators (list #\/ #\:)))) (unless (and (= (length tokens) 3) (string= (first tokens) "rosrpc")) (error "URI ~a was not of the expected form" uri)) (values (second tokens) (read-from-string (third tokens))))) (defmacro roslisp-error (str &rest args) `(progn (ros-error nil ,str ,@args) (error ,str ,@args))) (defmacro roslisp-warn (str &rest args) `(progn (ros-warn nil ,str ,@args) (warn ,str ,@args))) (defun get-ip-address (hostname) "Map from hostname into a vector of the form #(127 0 0 1)" (let ((address-vector (or (parse-string-ip-address hostname) (cond ((member hostname '("localhost" "127.0.0.1") :test #'equal) #(127 0 0 1)) ((and (typep hostname '(vector * 4)) (every #'numberp hostname)) hostname) (t (let ((address (lookup-hostname-ip-address hostname))) (etypecase address (string (let ((tokens (tokens address :separators (list #\.)))) (map 'vector #'(lambda (token) (read-from-string token)) tokens))) (vector address) (list (coerce address 'vector))))))))) (if (and (typep address-vector '(vector * 4)) (every #'(lambda (x) (typep x '(mod 256))) address-vector)) address-vector (error "Converting ~a into ip address vector resulted in ~a, which doesn't look right" hostname address-vector)))) (defun parse-string-ip-address (hostname) "If string can be parsed as 4 numbers separated by .'s return vector of those numbers, else return nil" (let ((tokens (tokens hostname :separators (list #\.)))) (when (= 4 (length tokens)) (let ((read-tokens (map 'vector #'read-from-string tokens))) (when (every #'(lambda (x) (typep x '(mod 256))) read-tokens) read-tokens))))) (defun ip-address-string (address) (etypecase address (string address) (list (format nil "~{~a~^.~}" address)) (vector (ip-address-string (coerce address 'list))))) (defun lookup-hostname-ip-address (hostname) (host-ent-address (get-host-by-name hostname))) (defun hostname () (or (sb-ext:posix-getenv "ROS_HOSTNAME") (sb-ext:posix-getenv "ROS_IP") (run-external "hostname"))) (defun get-topic-class-name (topic) "Given a topic foo with message type, say the string /std_msgs/bar, this returns the symbol named bar from the package std_msgs. The topic must be one that has already been advertised or subscribed to." (let ((sub (gethash topic *subscriptions*)) (pub (gethash topic *publications*))) (assert (or sub pub) nil "Can't get class name of topic ~a that we neither publish nor subscribe" topic) (let* ((type (if sub (sub-topic-type sub) (pub-topic-type pub))) (tokens (tokens type :separators '(#\/)))) (assert (= 2 (length tokens)) nil "topic type ~a of topic ~a was not of the form foo/bar" type topic) (let* ((class-name (concatenate 'string (string-upcase (second tokens)))) (pkg-name (string-upcase (concatenate 'string (first tokens) "-msg"))) (class-symbol (find-symbol class-name pkg-name))) (assert class-symbol nil "Could not find symbol ~a in ~a" class-name pkg-name) class-symbol)))) (defvar *message-dir-cache* (make-hash-table :test #'equal)) (defvar *service-dir-cache* (make-hash-table :test #'equal)) (defun run-external (cmd &rest args) (let ((str (make-string-output-stream))) (let ((proc (sb-ext:run-program cmd args :search t :output str :wait nil))) (sb-ext:process-wait proc) (if (zerop (sb-ext:process-exit-code proc)) (first (last (tokens (get-output-stream-string str) :separators '(#\Newline)))) (error "Received exit code ~a when running external process ~a with args ~a" (sb-ext:process-exit-code proc) cmd args))))) (defvar *loaded-files* (make-hash-table :test #'equal)) (defmacro load-if-necessary (f) "load-if-necessary FILENAME. FILENAME is a string containing a path to a file. Maintains an internal list (per Lisp session) of which ones have been already loaded, and does not reload a file twice (to avoid annoying warnings). DEPRECATED!" (declare (ignorable f)) (error "load-if-necessary deprecated!")) (defmacro load-message-types (&rest message-types) `(progn ,@(mapcar (lambda (msg-type) (let ((msg-system-name (concatenate 'string (if (symbolp msg-type) (string-downcase (symbol-name msg-type)) msg-type) "-msg"))) `(asdf:operate 'asdf:load-op ,msg-system-name))) message-types))) (defmacro load-service-types (&rest service-types) "load-service-types &rest SERVICE-TYPES Each service type is a string of form package/service. Loads the corresponding Lisp files. Makes sure to load things only once. This means that if the .lisp files are changed during the current Lisp session (which wouldn't happen in the normal scheme of things), you will have to manually reload the file rather than using this function." `(progn ,@(mapcar (lambda (msg-type) (let ((msg-system-name (concatenate 'string (if (symbolp msg-type) (string-downcase (symbol-name msg-type)) msg-type) "-srv"))) `(asdf:operate 'asdf:load-op ,msg-system-name))) service-types))) (defun standalone-exec-debug-hook (a b) (declare (ignore b)) (when (eq *node-status* :running) (invoke-restart 'shutdown-ros-node a) )) (defmacro store-message-in (place) "Macro store-message-in PLACE Used if you want a callback function for a topic that just stores the message in some variable. Expands to definition of a function that sets PLACE to equal its argument." (let ((message (gensym))) `#'(lambda (,message) (setf ,place ,message)))) (defmacro load-msg (msg-type) "Intended for interactive use. Pass it a string which is the ros name of the given message, e.g. std_msgs/String. Loads the corresponding class and calls use-package on that package." (let ((pkg-name (first (roslisp-utils:tokens msg-type :separators "/")))) `(progn (load-message-types ,msg-type) (use-package ,(intern (string-upcase (concatenate 'string pkg-name "-msg")) :keyword))))) (defmacro load-srv (msg-type) "Intended for interactive use. Pass it a string which is the ros name of the given message, e.g. std_msgs/String. Loads the corresponding class and calls use-package on that package." (let ((pkg-name (first (roslisp-utils:tokens msg-type :separators "/")))) `(progn (load-service-types ,msg-type) (use-package ,(intern (string-upcase (concatenate 'string pkg-name "-srv")) :keyword))))) (defun lookup-topic-type (type) "if it's, e.g., the string std_msgs/String just return it, if it's, e.g., 'std_msgs:, return the string std_msgs/String" (etypecase type (string (ros-datatype (string-to-ros-msgtype-symbol type))) (symbol (ros-datatype type)))) (defun make-service-symbol (type-string) (let ((pkg (find-package (string-upcase (concatenate 'string (subseq type-string 0 (position #\/ type-string)) "-srv")))) (msg-name (string-upcase (subseq type-string (1+ (position #\/ type-string)))))) (assert pkg () "Service-package not found. Maybe it is not loaded?") (nth-value 0 (intern msg-name pkg)))) roslisp-1.9.20/src/slave.lisp000066400000000000000000000225331270365674000161070ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package roslisp) (defparameter *xmlrpc-timeout* 1.0 "How many seconds to wait until giving up") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Slave API - implements XML-RPC calls to this node from ;; other nodes or from the master node. ;; ;; 1) XML-RPC calls have API-wide locking - only one can ;; be active at a time. ;; 2) The funny function names are because XML-RPC is ;; case sensitive and Lisp symbols are not, by default. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun |getPid| (caller-id) "getPid XML-RPC method. Takes no arguments, returns 1 upon success." (declare (ignore caller-id)) (let ((pid (sb-unix:unix-getpid))) (list 1 (format nil "PID is ~a" pid) pid))) (defun |shutdown| (caller-id) "shutdown XML-RPC method. Takes no arguments, shuts down the ROS node." ;; No need to acquire lock as shutdown acquires it (shutdown-ros-node) (list 1 (format nil "shutdown by ~a" caller-id) nil)) (defun |publisherUpdate| (caller-id topic publishers) "publisherUpdate XMl-RPC method. TOPIC : string naming the topic PUBLISHERS : list of publishers, each of which is a list (ADDRESS PORT)." (declare (ignore caller-id)) (ros-debug (roslisp topic) "Publisher update ~a ~a" topic publishers) (with-recursive-lock (*ros-lock*) (update-publishers topic publishers))) (defun |getBusInfo| (caller-id) "getBusInfo XML-RPC method Used to get info about the node's connections (e.g., for rosnode info)" (ros-debug (roslisp slave) "Received call to getBusInfo from ~a" caller-id) (with-recursive-lock (*ros-lock*) (list 1 (format nil "getBusInfo call returning") (nconc (publications-info) (subscriptions-info))))) (defun publications-info () "Helper for getBusInfo" (loop :for topic :being :each :hash-key :in *publications* :using (:hash-value pub) :append (mapcar #'(lambda (c) (publication-info topic c)) (subscriber-connections pub)))) (defun publication-info (topic conn) (list (sxhash conn) (subscriber-uri conn) "o" "TCPROS" topic)) (defun subscriptions-info () "Helper for getBusInfo" (loop :for topic :being :each :hash-key :in *subscriptions* :using (:hash-value sub) :append (mapcar #'(lambda (c) (subscription-info topic c)) (publisher-connections sub)))) (defun subscription-info (topic conn) (list (sxhash conn) (uri conn) "i" "TCPROS" topic)) (defun |requestTopic| (caller-id topic protocols) "requestTopic XML-RPC method TOPIC: string naming a topic PROTOCOLS: list of protocols, each of which is a list (PROTOCOL-NAME-STRING . PROTOCOL-INBOUND-PARAMS) If the topic is not one published by this node, return -1. If none of the protocols supported by this node return 0. Else return 1, msg, (PROTOCOL-NAME-STRING . PROTOCOL-OUTBOUND-PARAMS) Notes 1. Currently only TCPROS is supported. There are no other inbound params, and the outbound params are address, port (integers). 2. This call does not actually set up the transport over the agreed-upon protocol. In the TCP case, the subscriber must then connect to the given address and port over TCP, and send a string containing the topic name and MD5 sum." (declare (string topic) (sequence protocols)) (ros-debug (roslisp slave request-topic) "Received call `requestTopic ~a ~a ~a" caller-id topic protocols) (with-recursive-lock (*ros-lock*) (if (find "TCPROS" protocols :key #'first :test #'string=) (if (hash-table-has-key *publications* topic) ;; TCPROS-specific (list 1 (format nil "ready on ~a:~a" *tcp-server-hostname* *tcp-server-port*) (list "TCPROS" *tcp-server-hostname* *tcp-server-port*)) ;; If I don't know about this topic (list -1 (format nil "Not a publisher of ~a" topic) nil)) ;; If TCPROS is not on the protocol list (list 0 (format nil "Protocol list ~a does not contain TCPROS" protocols) nil)))) ;; Register the above operations as XML-RPC methods (import '(|getPid| |shutdown| |publisherUpdate| |requestTopic| |getBusInfo|) 's-xml-rpc-exports) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun update-publishers (topic publishers) "Helper called by publisherUpdate and registerSubscription" ;; Sometimes this gets called with an empty string for publishers (a bug in s-xml-rpc?) ;; In that case, replace it with the empty list (when (stringp publishers) (if (= 0 (length (string-trim '(#\Space #\Tab #\Newline) publishers))) (setf publishers nil) (progn (ros-error roslisp "In update publishers, got a string ~a rather than a list of publishers. Skipping." publishers) (return-from update-publishers)))) ;; Get the current info for this topic (mvbind (subscription known) (gethash topic *subscriptions*) (cond (known ;; Remove no-longer-existing publisher connections (setf (publisher-connections subscription) (delete-if #'(lambda (conn) (not (member (uri conn) publishers :test #'equal))) (publisher-connections subscription))) ;; Add and subscribe to new ones (dolist (pub publishers (list 1 "updated" 0)) (unless (member pub (publisher-connections subscription) :test #'equal :key #'uri) ;; TCPROS-specific to assume connection consists of a socket and a stream (handler-case (mvbind (conn str) (subscribe-publisher pub topic) (push (make-publisher-connection :publisher-socket conn :publisher-stream str :uri pub) (publisher-connections subscription))) (sb-bsd-sockets:connection-refused-error (c) (ros-debug (roslisp tcp) "Socket error ~a when attempting to subscribe to ~a; skipping" c pub))) ))) ((not known) (list 0 (format nil "I'm not interested in topic ~a" topic) 0))))) (defun subscribe-publisher (uri topic) "Connect over XML-RPC to URI, negotiate a transport, and return the connection information. Right now, the transport must be TCPROS and the return value is the socket." (ros-debug (roslisp topic) "~&Subscribing to ~a at ~a" topic uri) (unless (hash-table-has-key *subscriptions* topic) (roslisp-error "I'm not subscribed to ~a" topic)) (dotimes (repeat 3 (error 'simple-error :format-control "Timeout when subscribing publisher at ~a for topic ~a, check publisher node status. Change *xmlrpc-timeout* to increase wait-time." :format-arguments (list uri topic) )) (handler-case (return (dbind (protocol address port) ;; Check if it's our publisher if that's the case don't request the topic ;; using a ros-rpc-call since it would deadlock and time out (if (equal uri *xml-rpc-caller-api*) (dbind (code msg vals) (|requestTopic| *ros-node-name* topic (list (list "TCPROS"))) (when (<= code 0) (cerror "Ignore and continue" 'ros-rpc-error :call (cons "requestTopic" (list *ros-node-name* topic (list (list "TCPROS")))) :uri uri :code code :message msg :vals vals)) vals) (with-function-timeout *xmlrpc-timeout* (lambda () (ros-rpc-call uri "requestTopic" topic (list (list "TCPROS")))))) (if (string= protocol "TCPROS") (setup-tcpros-subscription address port topic) (ros-error (roslisp tcp) "Protocol ~a did not equal TCPROS... skipping connection" protocol)))) (function-timeout () ;;just retry nil))))roslisp-1.9.20/src/sockets.lisp000066400000000000000000000047471270365674000164570ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package roslisp) (defun close-socket (socket) "Remove all handlers from this socket and close it" (ros-debug (roslisp tcp) "~&Closing ~a" socket) (invalidate-descriptor (socket-file-descriptor socket)) (socket-close socket)) (defun tcp-connect (hostname port) "Helper that connects over TCP to this host and port, and returns 1) The stream 2) The socket" (let ((connection (make-instance 'inet-socket :type :stream :protocol :tcp)) (ip-address (get-ip-address hostname))) (ros-debug (roslisp tcp) "~&Connecting to ~a ~a" ip-address port) (socket-connect connection ip-address port) (values (socket-make-stream connection :output t :input t :element-type '(unsigned-byte 8)) connection))) roslisp-1.9.20/src/tcpros.lisp000066400000000000000000000574001270365674000163100ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defparameter *tcp-timeout* 5.0 "How many seconds to wait until giving up") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utility ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro bind-from-header (bindings header &body body) "Simplify binding a bunch of fields from a header and signaling a condition if there's a problem" (let ((h (gensym))) `(let ((,h ,header)) (let ,(mapcar #'(lambda (binding) (list (first binding) `(lookup-alist ,h ,(second binding)))) bindings) ,@body)))) (define-condition malformed-tcpros-header (error) ((msg :accessor msg :initarg :msg))) (defun tcpros-header-assert (condition str &rest args) (unless condition (error 'malformed-tcpros-header :msg (apply #'format nil str args)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ROS Node connection server ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ros-node-tcp-server (port) "Return a passive socket that listens for connections on the given port. The handler for incoming connections is (the function returned by) server-connection-handler." (let ((socket (make-instance 'inet-socket :type :stream :protocol :tcp)) (ip-address #(0 0 0 0))) (setf (sb-bsd-sockets:sockopt-reuse-address socket) t) (socket-bind socket ip-address port) (ros-debug (roslisp tcp) "Bound tcp listener ~a" socket) (socket-listen socket 5) (sb-sys:add-fd-handler (socket-file-descriptor socket) :input (server-connection-handler socket)) socket)) (defun server-connection-handler (socket) "Return the handler for incoming connections to this socket. The handler accepts the connection, and decides whether its a topic or service depending on whether the header has a topic field, and passes it to handle-topic-connection or handle-service connection as appropriate. If the header cannot be parsed or lacks the necessary fields, send an error header across the socket, close it, and print a warning message on this side." #'(lambda (fd) (declare (ignore fd)) (let* ((connection (socket-accept socket)) (stream (socket-make-stream connection :element-type '(unsigned-byte 8) :output t :input t :buffering :none))) (flet ((close-connection (&key (abort t)) "Closes the connection when an error occurred." ;; We first close the stream with the abort parameter ;; since SOCKET-CLOSE does not allow to specify ;; abort. This function is ment to be used in error ;; handling since SOCKET-CLOSE currently has a nasty ;; bug that prevents it from closing broken ;; connections. (close stream :abort abort) (socket-close connection))) (ros-debug (roslisp tcp) "Accepted TCP connection ~a" connection) (mvbind (header parse-error) (ignore-errors (parse-tcpros-header stream)) ;; Any errors guaranteed to be handled in the first cond clause (ros-debug (roslisp tcp) "Parsed header: ~a ~:[~;Parse error ~:*~a~]" header parse-error) (handler-case (cond ((null header) (ros-info (roslisp tcp) "Ignoring connection attempt due to error parsing header: '~a'" parse-error) (socket-close connection)) ((assoc "service" header :test #'equal) (handle-service-connection header connection stream)) ((equal (cdr (assoc "probe" header :test #'equal)) "1") (ros-warn roslisp "Unexpectedly received a tcpros connection with probe set to 1. Closing connection.") (socket-close connection)) ((assoc "topic" header :test #'equal) (handle-topic-connection header connection stream)) ) (malformed-tcpros-header (c) (send-tcpros-header stream "error" (msg c)) (warn "Connection server received error ~a when trying to parse header ~a. Ignoring this connection attempt." (msg c) header) (close-connection)) (stream-error (c) (declare (ignore c)) (ros-debug (roslisp tcp) "stream error on connection to service client (could be a probe)") (close-connection)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Topics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun handle-topic-connection (header connection stream) "Handle topic connection by checking md5 sum, sending back a response header, then adding this socket to the publication list for this topic. If the connection comes from this caller no response needs to be send." (bind-from-header ((topic "topic") (md5 "md5sum") (uri "callerid")) header (let ((pub (gethash topic *publications*))) (tcpros-header-assert pub "unknown-topic") (let ((my-md5 (md5sum topic)) (caller-id (caller-id))) (tcpros-header-assert (or (equal md5 "*") (equal md5 my-md5)) "md5sums do not match for ~a: ~a vs ~a" topic md5 my-md5) ;; Send a response if you didn't subscribed to yourself (unless (equal uri caller-id) (send-tcpros-header stream "type" (ros-datatype topic) "callerid" caller-id "message_definition" (message-definition topic) "latching" (if (is-latching pub) "1" "0") "md5sum" my-md5))) ;; Add this subscription to the list for the topic (let ((sub (make-subscriber-connection :subscriber-socket connection :subscriber-stream stream :subscriber-uri uri))) (ros-debug (roslisp tcp) "~&Adding ~a to ~a for topic ~a" sub pub topic) (push sub (subscriber-connections pub)) (when (and (is-latching pub) (last-message pub)) (ros-debug (roslisp tcp) "~&Resending latched message to new subscriber") (tcpros-write (last-message pub) stream)))))) (defparameter *setup-tcpros-subscription-max-retry* 3) (defun setup-tcpros-subscription (hostname port topic) "Connect to the publisher at the given address and do the header exchange, then start a thread that will deserialize messages onto the queue for this topic." (check-type hostname string) (mvbind (stream connection) (tcp-connect hostname port) (ros-debug (roslisp tcp) "~&Successfully connected to ~a:~a for topic ~a" hostname port topic) ;; Check if we try to subscribe to our own publisher (if (and (equal hostname *tcp-server-hostname*) (equal port *tcp-server-port*)) (setup-tcpros-subscription-to-self hostname port topic connection stream) (setup-tcpros-subscription-to-strangers hostname port topic connection stream)) (values stream connection))) (defun setup-tcpros-subscription-to-self (hostname port topic connection stream) "Helper function for setting up a tcpros-subscription with a publisher that uses the same tcp-server." (mvbind (sub known) (gethash topic *subscriptions*) (assert known nil "Topic ~a unknown. This error should have been caught earlier!" topic) (send-tcpros-header stream "topic" topic "md5sum" (md5sum topic) "type" (ros-datatype topic) "callerid" (caller-id)) ;; Spawn a dedicated thread to deserialize messages off the socket onto the queue (spawn-connection-thread hostname port topic stream connection (buffer sub)))) (defun setup-tcpros-subscription-to-strangers (hostname port topic connection stream) "Helper function for setting up a tcpros-subscriptions with a publisher that doesn't uses this tcp-server." (dotimes (retry-count *setup-tcpros-subscription-max-retry* (error 'simple-error :format-control "Timeout when trying to communicate with publisher ~a:~a for topic ~a, check publisher node status. Change *tcp-timeout* to increase wait-time." :format-arguments (list hostname port topic))) (when (> retry-count 0) (ros-warn (roslisp tcpros) "Failed to communicate with publisher ~a:~a for topic ~a, retrying: ~a" hostname port topic retry-count)) (handler-case (mvbind (sub known) (gethash topic *subscriptions*) (assert known nil "Topic ~a unknown. This error should have been caught earlier!" topic) ;; Send header and receive response (send-tcpros-header stream "topic" topic "md5sum" (md5sum topic) "type" (ros-datatype topic) "callerid" (caller-id)) (let ((response (with-function-timeout *tcp-timeout* (lambda () (parse-tcpros-header stream))))) (when (assoc "error" response :test #'equal) (roslisp-error "During TCPROS handshake, publisher sent error message ~a" (cdr (assoc "error" response :test #'equal)))) ;; TODO need to do something with the response, handle AnyMsg (see tcpros.py) ;; Spawn a dedicated thread to deserialize messages off the socket onto the queue (spawn-connection-thread hostname port topic stream connection (buffer sub))) ;; If nothing failed return from dotimes (return)) (malformed-tcpros-header (c) (send-tcpros-header stream "error" (msg c)) (socket-close connection) (error c)) (function-timeout () ;;just retry nil)))) (defun spawn-connection-thread (hostname port topic stream connection buffer) "Spawns a dedicated thread to deserialize messages off the socket onto the queue and adds it to the deserialization-threads." (let ((connection-thread (sb-thread:make-thread #'(lambda () (block thread-block (unwind-protect (handler-bind ((error #'(lambda (c) (unless *break-on-socket-errors* (ros-debug (roslisp tcp) "Received error ~a when reading connection to ~a:~a on topic ~a. Connection terminated." c hostname port topic) (return-from thread-block nil))))) (loop (unless (eq *node-status* :running) (error "Node status is ~a" *node-status*)) ;; Read length (ignored) (dotimes (i 4) (read-byte stream)) (let ((msg (deserialize (get-topic-class-name topic) stream))) (let ((num-dropped (enqueue msg buffer))) (ros-debug (roslisp tcp) (> num-dropped 0) "Dropped ~a messages on topic ~a" num-dropped topic))))) ;; Always close the connection before leaving the thread (socket-close connection)))) :name (format nil "Roslisp thread for subscription to topic ~a published from ~a:~a" topic hostname port)))) (assert (eq (mutex-owner *ros-lock*) *current-thread*) nil "Code assumption violated; not holding lock in setup-tcpros-subscription") (ros-debug (roslisp deserialization-thread) "Adding deserialization thread for connection on topic ~a to ~a:~a" topic hostname port) (push connection-thread *deserialization-threads*))) (defvar *stream-error-in-progress* nil) (defun tcpros-write (msg str) (or (unless (gethash str *broken-socket-streams*) (handler-case ;; We need to serialize the data first to a string stream and ;; then send the whole string at once over the socket. We ;; also need to prevent the send operation from ;; interrupts. Otherwise, when messages do not get sent ;; completely, we run out of sync and the connection to the ;; client will be lost. (let* ((msg-size (serialization-length msg)) (data-strm (make-instance 'msg-serialization-stream :buffer-size (+ msg-size 4)))) (serialize-int msg-size data-strm) (serialize msg data-strm) (sb-sys:without-interrupts (write-sequence (serialized-message data-strm) str :end (file-position data-strm)) ;; Technically, force-output isn't supposed to be called on binary streams... (force-output str) 1 ;; Returns number of messages written )) ((or sb-bsd-sockets:socket-error stream-error) (c) (unless *stream-error-in-progress* (let ((*stream-error-in-progress* t)) (ros-debug (roslisp tcp) "Received error ~a when writing to ~a. Skipping from now on." c str))) (setf (gethash str *broken-socket-streams*) t) 0))) 0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Services ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun handle-service-connection (header connection stream) "Handle service connection. For now, we assume a single request, which is processed immediately in this thread." (bind-from-header ((md5 "md5sum") (service-name "service")) header (let* ((service (gethash service-name *services*)) (is-probe (equal (cdr (assoc "probe" header :test #'equal)) "1"))) (tcpros-header-assert service "Unknown service") (let ((my-md5 (string-downcase (service-md5 service)))) (tcpros-header-assert (or (equal md5 "*") (equal md5 my-md5)) "md5 sums don't match for ~a: ~a vs ~a" service-name md5 my-md5) (send-tcpros-header stream "md5sum" my-md5 "callerid" (caller-id) "type" (service-ros-type service) "request_type" (service-request-ros-type service) "response_type" (service-response-ros-type service))) (unwind-protect (unless is-probe (handle-single-service-request stream (service-request-class service) (service-callback service))) (sb-thread:make-thread #'(lambda () (sleep 10.0) (ros-debug (roslisp service) "In service connection cleanup") (when (socket-open-p connection) (ros-debug (roslisp service) "Connection for call to ~a still open after 10 seconds; closing" service-name) (socket-close connection)))))))) (define-condition service-error (simple-error) ()) (defun handle-single-service-request (stream request-class-name callback) ;; Read length (dotimes (i 4) (read-byte stream)) (flet ((write-service-error (msg) (assert (stringp msg)) (write-byte 0 stream) (serialize-string msg stream) (finish-output stream))) (let ((msg (deserialize request-class-name stream))) (ros-debug (roslisp service tcp) "Deserialized service request of type ~a" request-class-name) (handler-case (let ((response (funcall callback msg))) (ros-debug (roslisp service tcp) "Callback returned") (write-byte 1 stream) (serialize-int (serialization-length response) stream) (ros-debug (roslisp service tcp) "Wrote response length ~a" (serialization-length response)) (serialize response stream) (ros-debug (roslisp service tcp) "Wrote response; flushing stream.") (finish-output stream) (ros-debug (roslisp service tcp) "Finished handling service request")) (service-error (e) (let ((msg (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e)))) (ros-debug (roslisp service tcp) "Service-error during request ~a:~% ~a" e msg) (write-service-error (concatenate 'string "service cannot process request: " msg)))) (error (e) (let ((msg (format nil "~a" e))) (ros-error (roslisp service tcp) "Error processing request ~a:~% ~a" e msg) (write-service-error (concatenate 'string "error processing request: " msg)))))))) (defun tcpros-establish-service-connection (hostname port service-name request-class &optional (persistent nil)) (check-type hostname string) (multiple-value-bind (stream socket) (tcp-connect hostname port) (handler-bind ((error (lambda (e) (declare (ignore e)) (socket-close socket)))) (send-tcpros-header stream "service" service-name "md5sum" (md5sum request-class) "callerid" (caller-id) "persistent" (if persistent "1" "0"))) (values stream socket (with-function-timeout *tcp-timeout* (lambda () (parse-tcpros-header stream)))))) (define-condition service-call-error (error) ((message :initarg :message :reader service-call-error-message))) (defun tcpros-do-service-request (stream request response-type) ;; Clear the input stream. In case the service call uses a ;; persistent service and the service call got interrupted after the ;; request has been sent, it can happen that the result is still in ;; the stream. Get rid of all old results before sending another ;; request. (clear-input stream) (tcpros-write request stream) (let ((ok-byte (read-byte stream nil))) (unless (eq ok-byte 1) (error 'service-call-error :message (handler-case (deserialize-string stream) ;; TODO(lorenz): don't catch all errors. (error nil)))) (let ((len (deserialize-int stream))) (declare (ignore len)) (prog1 (deserialize response-type stream) (assert (not (listen stream)) () "Still bytes in the stream. It seems like we went out of sync."))))) (defun tcpros-call-service (hostname port service-name req response-type) (check-type hostname string) (dotimes (retry-count *setup-tcpros-subscription-max-retry* (error 'simple-error :format-control "Timeout when trying to communicate with ~a:~a for service ~a, check service node status. Change *tcp-timeout* to increase wait-time." :format-arguments (list hostname port service-name))) (when (> retry-count 0) (ros-warn (roslisp tcpros) "Failed to communicate with ~a:~a for service-name ~a, retrying: ~a" hostname port service-name retry-count)) (handler-case (return (multiple-value-bind (str socket) (tcpros-establish-service-connection hostname port service-name (class-name (class-of req))) (unwind-protect (handler-case (tcpros-do-service-request str req response-type) (service-call-error (e) (if (service-call-error-message e) (roslisp-error "service-call to ~a:~a with request ~a failed with message: ~a" hostname port req (service-call-error-message e)) (roslisp-error "service-call to ~a:~a with request ~a failed." hostname port req)))) (socket-close socket)))) (function-timeout () ;;just retry nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun caller-id () "The callerid field of any tcpros header used by a node" (fully-qualified-name *ros-node-name*)) (defun send-tcpros-header (str &rest args) (assert (evenp (length args)) nil "send-tcpros-header received odd number of arguments ~a" args) (let ((l args) (key-value-pairs nil) (total-length 0)) (while l (let ((next-pair (format nil "~a=~a" (pop l) (pop l)))) (incf total-length (+ 4 (length next-pair))) ;; 4 for the 4-byte length at the beginning (push next-pair key-value-pairs))) (ros-debug (roslisp tcp header) "Sending tcpros header ~a" key-value-pairs) (serialize-int total-length str) (dolist (pair key-value-pairs) (serialize-string pair str))) (force-output str)) (defun parse-tcpros-header (str) (let ((remaining-length (deserialize-int str)) (key-value-pairs nil)) (while (> remaining-length 0) (let ((field-string (deserialize-string str))) (decf remaining-length (+ 4 (length field-string))) ;; 4 for the length at the beginning (unless(>= remaining-length 0) (roslisp-error "Error parsing tcpros header: header length and field lengths didn't match")) (push (parse-header-field field-string) key-value-pairs) )) (ros-debug (roslisp tcp header) "Received tcpros header ~a" key-value-pairs) key-value-pairs)) (defun parse-header-field (field-string) (let ((first-equal-sign-pos (position #\= field-string))) (if first-equal-sign-pos (cons (subseq field-string 0 first-equal-sign-pos) (subseq field-string (1+ first-equal-sign-pos))) (roslisp-error "Error parsing tcpros header field ~a: did not contain an '='" field-string)))) (defun lookup-alist (l key) (let ((pair (assoc key l :test #'equal))) (unless pair (error 'malformed-tcpros-header :msg (format nil "Could not find key ~a in ~a" key l))) (cdr pair))) roslisp-1.9.20/src/time.lisp000066400000000000000000000073151270365674000157340ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package :roslisp) (defun ros-time () "If *use-sim-time* is true (which is set upon node startup by looking up the ROS /use_sim_time parameter), return the last received time on the /time or /clock topics, or 0.0 if no time message received yet. Otherwise, return the unix time (seconds since epoch with microsecond precision)." #+sbcl (if *use-sim-time* (if *last-clock* (rosgraph_msgs-msg:clock *last-clock*) (progn (unless (mutex-owner *debug-stream-lock*) (ros-debug (roslisp time) "Returning time of 0.0 as use_sim_time was true and no clock messages received")) 0.0)) (multiple-value-bind (secs usecs) (sb-ext:get-time-of-day) (declare (type unsigned-byte secs) (type (unsigned-byte 31) usecs)) (float (+ secs (/ usecs 1d6))))) #-sbcl (error "Only supported in SBCL.")) (defun spin-until-ros-time-valid () (spin-until (> (ros-time) 0.0) 0.05 (every-nth-time 100 (ros-warn (roslisp time) "Waiting for valid ros-time before proceeding")))) (defun wait-duration (d) "Wait until time T+D, where T is the current ros-time." (spin-until-ros-time-valid) (let ((until (+ (ros-time) d))) (spin-until (>= (ros-time) until) .01 (every-nth-time 100 (ros-debug (roslisp time) "In wait-duration spin loop; waiting until ~a" until))))) ;;; Deprecated special variables (defvar *%time-base* (unix-time) "This variable is deprecated as of roslisp 1.9.18. Holds unix time (rounded to the nearest second) when roslisp was started") (define-symbol-macro *time-base* (progn (warn "roslisp:*time-base* is deprecated as of roslisp 1.9.18.") *%time-base*)) (defvar *%internal-time-base* (get-internal-real-time) "This variable is deprecated as of roslisp 1.9.18. Holds CL's internal time when roslisp was started") (define-symbol-macro *internal-time-base* (progn (warn "roslisp:*internal-time-base* is deprecated as of roslisp 1.9.18.") *%internal-time-base)) roslisp-1.9.20/utils/000077500000000000000000000000001270365674000144505ustar00rootroot00000000000000roslisp-1.9.20/utils/extended-reals.lisp000066400000000000000000000062031270365674000202460ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :roslisp-extended-reals (:use :cl) (:export :infty :-infty :ext+ :ext- :extmax)) (in-package :roslisp-extended-reals) ;(declaim (inline ext+ ext- ext>)) (defun ext+ (&rest args) (reduce 'add-ext args)) (defun ext- (a &rest args) (if args (reduce 'subtract (cons a args)) (negate a))) (defun extmax (&rest args) (when args (let ((m '-infty)) (dolist (x args m) (when (ext> x m) (setf m x)))))) (defun ext> (a b) (cond ((eql a 'infty) (not (eql b 'infty))) ((eql b '-infty) (not (eql a '-infty))) ((and (numberp a) (numberp b)) (> a b)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;(declaim (inline subtract negate)) (defun add-ext (a b) (cond ((symbolp a) (cond ((numberp b) a) ((eq a b) a) (t (assert nil nil "Can't add infty and -infty")))) ((symbolp b) b) (t (+ a b)))) (defun subtract (a b) (cond ((symbolp a) (cond ((numberp b) a) ((eq a b) (assert nil nil "Can't subtract infty or -infty from themselves.")) (t a))) ((eql b 'infty) '-infty) ((eql b '-infty) 'infty) (t (- a b)))) (defun negate (a) (case a (infty '-infty) (-infty 'infty) (otherwise (- a)))) roslisp-1.9.20/utils/float-bytes.lisp000066400000000000000000000126651270365674000176040ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package roslisp-utils) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Conversion functions for going to and from single and ;; double precision floating point values, assuming the ;; IEEE format (which one?). ;; ;; Code taken Peter Seibel's post to comp.lang.lisp: ;; http://groups.google.com/group/comp.lang.lisp/msg/11d500ef6e31a4ba ;; which presumably is in the public domain. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun encode-float-bits (float sign-byte exponent-byte mantissa-byte bias) (multiple-value-bind (original-mantissa original-exponent sign) (integer-decode-float (float float 0d0)) (multiple-value-bind (mantissa exponent) (scale original-mantissa original-exponent (1+ (byte-size mantissa-byte))) (incf exponent (byte-size mantissa-byte)) (when (zerop mantissa) (setf exponent (- bias))) (when (<= exponent (- bias)) (setf (values mantissa exponent) (denormalize original-mantissa original-exponent bias mantissa-byte))) (incf exponent bias) (when (> (integer-length exponent) (byte-size exponent-byte)) (setf mantissa 0 exponent (ldb (byte (byte-size exponent-byte) 0) (lognot 0)))) (let ((result 0)) (setf (ldb sign-byte result) (if (plusp sign) 0 1)) (setf (ldb exponent-byte result) exponent) (setf (ldb mantissa-byte result) mantissa) result)))) (defun decode-float-bits (bits sign-byte exponent-byte mantissa-byte bias) (let ((sign (if (zerop (ldb sign-byte bits)) 1 -1)) (exponent (ldb exponent-byte bits)) (mantissa (ldb mantissa-byte bits))) (if (= (logcount (ldb exponent-byte bits)) (byte-size exponent-byte)) (if (zerop mantissa) (if (plusp sign) 'positive-infinity 'negative-infinity) 'not-a-number) (progn (when (plusp exponent) (incf mantissa (expt 2 (byte-size mantissa-byte)))) (if (zerop exponent) (setf exponent (- 1 bias (byte-size mantissa-byte))) (setf exponent (- (- exponent (byte-size mantissa-byte)) bias))) (float (* sign (* mantissa (expt 2 exponent))) 0d0))))) (defun scale-integer (value bits) "Scale an integer value so it fits in the given number of bits." (if (zerop value) (values 0 0) (let ((scale (- bits (integer-length value)))) (values (round (* value (expt 2 scale))) scale)))) (defun scale (mantissa exponent mantissa-bits) "Scale an integer value so it fits in the given number of bits." (multiple-value-bind (mantissa scale) (scale-integer mantissa mantissa-bits) (values mantissa (- exponent scale)))) (defun denormalize (mantissa exponent bias mantissa-byte) (multiple-value-bind (mantissa exponent) (scale mantissa exponent (byte-size mantissa-byte)) (incf exponent (byte-size mantissa-byte)) (values (ash mantissa (- exponent (1+ (- bias)))) (- bias)))) (defun encode-single-float-bits (float) (let ((float (float float 0.0))) (encode-float-bits float (byte 1 31) (byte 8 23) (byte 23 0) 127))) (defun encode-double-float-bits (float) (let ((float (float float 0.0d0))) (encode-float-bits float (byte 1 63) (byte 11 52) (byte 52 0) 1023))) (defun decode-single-float-bits (bits) (decode-float-bits bits (byte 1 31) (byte 8 23) (byte 23 0) 127)) (defun decode-double-float-bits (bits) (decode-float-bits bits (byte 1 63) (byte 11 52) (byte 52 0) 1023)) roslisp-1.9.20/utils/hash-utils.lisp000066400000000000000000000140211270365674000174200ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package roslisp-utils) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Hash tables with general hash functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defstruct gen-hash-table table hash-fn) (defun make-hash-table* (&rest args &key (hash-fn #'identity hsupp) (test #'eql t-supp)) "make-hash-table* &rest ARGS Portable version of hash tables with nonstandard hash functions ARGS are the arguments to hash table, with two additional keywords. HASH-FN : a function of one argument that returns an object. Defaults to #'identity. TEST: a function of two arguments that must be one of #'equal, #'equalp, #'eql, or #'eq. Defaults to #'eql. The assumption will be that given two objects X and Y that are 'the same', their images under HASH-FN are equal w.r.t TEST." (assert (and args (is-standard-equality-test test))) (flet ((remove-if-necessary (args supp key) (if supp (aif (position key args) (if (zerop it) (cddr args) (progn (setf (cdr (nthcdr (1- it) args)) (nthcdr (+ it 2) args)) args)) args) args))) (let ((actual-args (copy-list args))) (setf actual-args (remove-if-necessary actual-args hsupp ':hash-fn) actual-args (remove-if-necessary actual-args t-supp ':test)) (make-gen-hash-table :table (apply #'make-hash-table :test test actual-args) :hash-fn hash-fn)))) (defgeneric gethash* (key ht) (:documentation "gethash* KEY TABLE To be used with tables created with make-hash-table*. Also works for regular hash tables.") (:method (key (ht hash-table)) (gethash key ht)) (:method (key (ht gen-hash-table)) (with-struct (gen-hash-table- table hash-fn) ht (let ((p (gethash (funcall hash-fn key) table))) (if p (values (cdr p) t) (values nil nil)))))) (defgeneric sethash* (key ht val) (:method (key (ht hash-table) val) (setf (gethash key ht) val)) (:method (key (ht gen-hash-table) val) (with-struct (gen-hash-table- table hash-fn) ht (let* ((k (funcall hash-fn key)) (p (gethash k table))) (if p (setf (cdr p) val) (setf (gethash k table) (cons key val))) val)))) (defgeneric hash-table-test* (ht) (:documentation "hash-table-test* GEN-HASH-TABLE. Works for generalized hash tables. Also, unlike hash-table-test, returns a function rather than a symbol.") (:method ((ht hash-table)) (symbol-function (hash-table-test ht))) (:method ((ht gen-hash-table)) (with-struct (gen-hash-table- table hash-fn) ht (let ((test (symbol-function (hash-table-test table)))) #'(lambda (x y) (funcall test (funcall hash-fn x) (funcall hash-fn y))))))) (defgeneric hash-table-count* (ht) (:method ((ht hash-table)) (hash-table-count ht)) (:method ((ht gen-hash-table)) (hash-table-count (gen-hash-table-table ht)))) (defgeneric remhash* (key ht) (:method (key (ht hash-table)) (remhash key ht)) (:method (key (ht gen-hash-table)) (with-struct (gen-hash-table- table hash-fn) ht (remhash (funcall hash-fn key) table)))) (defgeneric hash-table-has-key (h k) (:documentation "hash-table-has-key HASHTABLE X. Does the HASHTABLE contain (an item that satisfies the table's test together with) X? Works with generalized hash tables also.") (:method ((h hash-table) x) (mvbind (y pres) (gethash x h) (declare (ignore y)) pres)) (:method ((h gen-hash-table) x) (hash-table-has-key (gen-hash-table-table h) (funcall (gen-hash-table-hash-fn h) x)))) (defsetf gethash* sethash*) (defgeneric hash-keys (h) (:documentation "hash-keys HASHTABLE. Return list of keys in some order. Works for generalized hash tables.") (:method ((h hash-table)) (loop for k being each hash-key in h collecting k)) (:method ((h gen-hash-table)) (loop for v being each hash-value in (gen-hash-table-table h) collect (car v)))) (defgeneric maphash* (fn h) (:documentation "maphash* FN H. Like maphash* but works for generalized hash tables.") (:method (fn (h hash-table)) (maphash fn h)) (:method (fn (h gen-hash-table)) (loop for v being each hash-value in (gen-hash-table-table h) do (funcall fn (car v) (cdr v))))) (defmacro do-hash ((k v h) &rest body) `(maphash* #'(lambda (,k ,v) (declare (ignorable ,k ,v)) ,@body) ,h)) roslisp-1.9.20/utils/queue.lisp000066400000000000000000000127231270365674000164720ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage :roslisp-queue (:documentation "A threadsafe implementation of queues") (:export :queue :make-queue :queue-empty :enqueue :queue-size :dequeue :dequeue-wait :wakeup :peek-front) (:use :cl :roslisp-utils :roslisp-extended-reals :sb-thread)) (in-package :roslisp-queue) (defstruct (queue (:conc-name nil) (:constructor create-queue)) lock read-cv max-size queue-size head tail) (defun make-queue (&key (sequence nil) (max-size 'infty)) "make-queue &key (SEQUENCE nil) (MAX-SIZE 'infty) Makes a queue out of SEQUENCE as if enqueueing the elements in sequence." (assert (or (eql max-size 'infty) (< (length sequence) max-size))) (let* ((head (etypecase sequence (list (copy-list sequence)) (vector (map 'list #'identity sequence)))) (tail (last head)) (queue (create-queue :head head :tail tail :lock (make-mutex :name "queue lock") :max-size max-size :queue-size (length head) :read-cv (make-waitqueue :name "queue reader waitqueue")))) queue)) (defun queue-empty (queue) "queue-empty QUEUE. Return t iff the queue has no elements." (null (head queue))) (defun enqueue (item q) "enqueue ITEM QUEUE. Add ITEM to the end of the QUEUE. If any dequeue-wait calls are waiting, one of them will wake up. If MAX-SIZE is exceeded, dequeue until not. Return the number of dropped items." (with-recursive-lock ((lock q)) (incf (queue-size q)) (let ((new-pair (list item)) (num-dropped 0)) (cond ((queue-empty q) (setf (head q) (setf (tail q) new-pair)) (condition-notify (read-cv q) 1)) (t (setf (tail q) (setf (cdr (tail q)) new-pair)) (repeat (extmax 0 (ext- (queue-size q) (max-size q))) (dequeue q) (incf num-dropped)))) num-dropped))) (defun dequeue (q) "dequeue QUEUE. Return 1) the first item on the queue if it exists (in this case the item is removed from the queue) 2) t if the queue was nonempty, nil otherwise. See also dequeue-wait." (with-recursive-lock ((lock q)) (decf (queue-size q)) (if (queue-empty q) (values nil nil) (multiple-value-prog1 (values (car (head q)) t) (setf (head q) (cdr (head q))))))) (defun dequeue-wait (q &key (allow-wakeup nil)) "dequeue-wait QUEUE &key (ALLOW-WAKEUP t). Sleep till QUEUE is nonempty, then return the first item and t, or wakeup is called on the queue, in which case return nil and nil. If there are multiple threads doing this, there is no guarantee about which enqueuing this one will wake up upon. However, the overall ordering of dequeued items will be FIFO. If wakeup is called when ALLOW-WAKEUP is nil, then an assert happens." ;; TODO wakeup isn't working (with-recursive-lock ((lock q)) (loop (if (queue-empty q) (condition-wait (read-cv q) (lock q)) (multiple-value-bind (item exists) (dequeue q) (if exists (return (values item t)) (unless allow-wakeup (assert nil nil "Thread woken up in call to dequeue-wait with allow-wakeup set to false")))))))) (defun wakeup (q) "Wakeup all dequeuers and tell them they aren't getting anything." ;; TODO wakeup isn't working (with-recursive-lock ((lock q)) (condition-broadcast (read-cv q)))) (defun peek-front (q) "peek-front QUEUE. Has the same return values as dequeue, but does not modify the queue." (with-recursive-lock ((lock q)) (if (queue-empty q) (values nil nil) (car (head q))))) (defmethod print-object ((q queue) str) (with-recursive-lock ((lock q)) (print-unreadable-object (q str :type t :identity nil) (format str "with elements ~a" (head q)))))roslisp-1.9.20/utils/roslisp-utils.asd000066400000000000000000000004121270365674000177670ustar00rootroot00000000000000 (defsystem :roslisp-utils :name "roslisp-utils" :components ((:file "utils") (:file "float-bytes" :depends-on ("utils")) (:file "extended-reals") (:file "queue" :depends-on ("utils" "extended-reals")) (:file "hash-utils" :depends-on ("utils")))) roslisp-1.9.20/utils/utils.lisp000066400000000000000000000313161270365674000165050ustar00rootroot00000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Software License Agreement (BSD License) ;; ;; Copyright (c) 2008, Willow Garage, Inc. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with ;; or without modification, are permitted provided that the ;; following conditions are met: ;; ;; * Redistributions of source code must retain the above ;; copyright notice, this list of conditions and the ;; following disclaimer. ;; * Redistributions in binary form must reproduce the ;; above copyright notice, this list of conditions and ;; the following disclaimer in the documentation and/or ;; other materials provided with the distribution. ;; * Neither the name of Willow Garage, Inc. nor the names ;; of its contributors may be used to endorse or promote ;; products derived from this software without specific ;; prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND ;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED ;; WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;; DAMAGE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defpackage roslisp-utils (:use :cl :sb-thread) (:export :mvbind :dbind :bind-pprint-args :force-format :until :while :repeat :unix-time :loop-at-most-every :spin-until :with-parallel-thread :every-nth-time :hash-table-has-key :pprint-hash :do-hash :tokens :serialize-int :deserialize-int :serialize-string :deserialize-string :filter :intern-compound-symbol :encode-single-float-bits :encode-double-float-bits :decode-single-float-bits :decode-double-float-bits)) (in-package :roslisp-utils) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro aif (test-form then-form &optional else-form) `(let ((it ,test-form)) (if it ,then-form ,else-form))) (defmacro dbind (pattern object &body body) "abbreviation for destructuring-bind" `(destructuring-bind ,pattern ,object ,@body)) (defmacro mvbind (vars form &body body) "abbreviation for multiple-value-bind" `(multiple-value-bind ,vars ,form ,@body)) (defmacro until (test &body body) `(loop (when ,test (return)) ,@body)) (defmacro while (test &body body) `(loop (unless ,test (return)) ,@body)) (defmacro bind-pprint-args ((str obj) args &body body) "bind-pprint-args (STR OBJ) ARGS &rest BODY STR, OBJ : unevaluated symbols ARGS : a list (evaluated) If ARGS has length 1, bind STR to t, OBJ to (FIRST ARGS). Otherwise, bind STR to (first args) and OBJ to (second args) ARGS. Then evaluate BDOY in this lexical context." (let ((x (gensym))) `(let ((,x ,args)) (condlet (((= 1 (length ,x)) (,str t) (,obj (first ,x))) (t (,str (first ,x)) (,obj (second ,x)))) ,@body)))) (defmacro repeat (n &body body) (let ((v (gensym))) `(dotimes (,v ,n) (declare (ignorable ,v)) ,@body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; condlet ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro condlet (clauses &body body) "condlet CLAUSES &rest BODY. CLAUSES is a list of which each member is a conditional binding or otherwise clause. There can be at most one otherwise clause and it must be the last clause. Each conditional binding is a list where the first element is a test and the remaining elements are the bindings to be made if the test succeeds. Each clause must bind the same set of variables. If one of the tests succeeds, the corresponding bindings are made, and the body evaluated. If none of the tests suceeds, the otherwise clause, if any, is evaluated instead of the body." (labels ((condlet-clause (vars cl bodfn) `(,(car cl) (let ,(condlet-binds vars cl) (,bodfn ,@(mapcar #'cdr vars))))) (condlet-binds (vars cl) (mapcar #'(lambda (bindform) (if (consp bindform) (cons (cdr (assoc (car bindform) vars)) (cdr bindform)))) (cdr cl)))) (let* ((var-names (mapcar #'car (cdr (first clauses)))) (otherwise-clause? (eql (caar (last clauses)) 'otherwise)) (actual-clauses (if otherwise-clause? (butlast clauses) clauses))) (assert (every (lambda (cl) (equal var-names (mapcar #'car (cdr cl)))) actual-clauses) nil "All non-otherwise-clauses in condlet must have same variables.") (let ((bodfn (gensym)) (vars (mapcar (lambda (v) (cons v (gensym))) var-names))) `(labels ((,bodfn ,(mapcar #'car vars) ,@body)) (cond ,@(mapcar (lambda (cl) (condlet-clause vars cl bodfn)) actual-clauses) ,@(when otherwise-clause? `((t (progn ,@(cdar (last clauses)))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Symbols ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun build-symbol-name (&rest args) "build-symbol-name S1 ... Sn. Each Si is a string or symbol. Concatenate them into a single long string (which can then be turned into a symbol using intern or find-symbol." (apply #'concatenate 'string (mapcar (lambda (x) (if (symbolp x) (symbol-name x) x)) args))) (defun intern-compound-symbol (&rest args) "intern-compound-symbol S1 ... Sn. Interns the result of build-symbol-name applied to the S." (intern (apply #'build-symbol-name args))) (defmacro with-struct ((name . fields) s &body body) "with-struct (CONC-NAME . FIELDS) S &rest BODY Example: with-struct (foo- bar baz) s ... is equivalent to let ((bar (foo-bar s)) (baz (foo-baz s)))... Note that despite the name, this is not like with-accessors or with-slots in that setf-ing bar above would not change the value of the corresponding slot in s." (let ((gs (gensym))) `(let ((,gs ,s)) (let ,(mapcar #'(lambda (f) `(,f (,(intern-compound-symbol name f) ,gs))) fields) ,@body)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Strings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun tokens (string &key (start 0) (separators (list #\space #\return #\linefeed #\tab))) (if (= start (length string)) '() (let ((p (position-if #'(lambda (char) (find char separators)) string :start start))) (if p (if (= p start) (tokens string :start (1+ start) :separators separators) (cons (subseq string start p) (tokens string :start (1+ p) :separators separators))) (list (subseq string start)))))) (defun deserialize-int (istream) (let ((int 0)) (setf (ldb (byte 8 0) int) (read-byte istream)) (setf (ldb (byte 8 8) int) (read-byte istream)) (setf (ldb (byte 8 16) int) (read-byte istream)) (setf (ldb (byte 8 24) int) (read-byte istream)) int)) (defun deserialize-string (istream) (let* ((__ros_str_len (deserialize-int istream)) (str (make-string __ros_str_len))) (dotimes (i (length str) str) do (setf (char str i) (code-char (read-byte istream)))))) (defun serialize-int (int ostream) (write-byte (ldb (byte 8 0) int) ostream) (write-byte (ldb (byte 8 8) int) ostream) (write-byte (ldb (byte 8 16) int) ostream) (write-byte (ldb (byte 8 24) int) ostream)) (defun serialize-string (string ostream) (serialize-int (length string) ostream) (map nil #'(lambda (c) (write-byte (char-code c) ostream)) string)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Time, event loops ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun unix-time () "seconds since 00:00:00, January 1, 1970" (- (get-universal-time) 2208988800)) (defun set-next-real-time-to-run (l time) (setf (car l) time)) (defun time-to-run (l) (car l)) (defun wait-until-ready (l) ;; Sbcl's sleep does not respect deadlines which causes severe ;; problems with CRAM. We don't use it directly. We explicitly take ;; into account deadlines. (let* ((current-time (get-internal-real-time)) (time-to-run (time-to-run l)) (deadline-seconds sb-impl::*deadline-seconds*) (stop-time (- time-to-run current-time))) (when (< current-time time-to-run) (tagbody :retry (cond ((or (not deadline-seconds) (> deadline-seconds time-to-run)) (sleep (/ stop-time internal-time-units-per-second))) (t (sleep deadline-seconds) (sb-sys:signal-deadline) (setq deadline-seconds sb-impl::*deadline-seconds*) (setf time-to-run (/ (float (- stop-time (get-internal-real-time)) 0.0d0) (float internal-time-units-per-second 0.0d0))) (when (plusp time-to-run) (go :retry)))))))) (defun run-and-increment-delay (l d) (let ((next-time (+ (time-to-run l) (* d internal-time-units-per-second)))) (wait-until-ready l) (set-next-real-time-to-run l next-time))) (defmacro loop-at-most-every (d &body body) "Like loop, except ensures that BODY is executed at most once every D seconds (though possibly arbitrarily slower, if it takes a long time)" (let ((delay (gensym)) (inc (gensym))) `(let ((,delay (list (get-internal-real-time))) (,inc ,d)) (loop (run-and-increment-delay ,delay ,inc) ,@body)))) (defmacro spin-until (test inc &body body) "Macro spin-until TEST INC &body BODY or spin-until TEST (INC TIMEOUT) &body BODY Every INC seconds, evaluate the form TEST, and return its value it becomes true. In the case with TIMEOUT specified, return two values: the first is the return value of TEST, and the second is T iff a timeout occurred (in which case the first value is meaningless)." (condlet (((listp inc) (actual-inc (first inc)) (timeout (second inc))) (t (actual-inc inc) (timeout nil))) (let ((init-time (gensym)) (test-var (gensym))) `(let ((,init-time (get-internal-real-time))) (declare (ignorable ,init-time)) (loop-at-most-every ,actual-inc (let ((,test-var ,test)) (when ,test-var (return ,test-var)) ,(when timeout `(when (and ,timeout (> (get-internal-real-time) (+ ,init-time (* ,timeout ,internal-time-units-per-second)))) (return (values nil t)))) ,@body)))))) (defmacro with-parallel-thread ((fn &optional name) &body body) "with-parallel-thread (FN NAME) &body BODY Start a thread that executes FN, named NAME (which defaults to the symbol FN). Then, in the current thread, execute BODY. After BODY exits, terminate the newly started thread as well (typically BODY will be a long-running loop). If FN is a symbol, it's replaced by (function FN). " (unless name (assert (symbolp fn) nil "If name is not provided to with-parallel-thread, the (unevaluated) fn argument should be a symbol") (setq name `',fn)) (let ((thread (gensym)) (fn (if (symbolp fn) `#',fn fn))) `(let ((,thread (sb-thread:make-thread ,fn :name ,name))) (unwind-protect (progn ,@body) (sb-thread:terminate-thread ,thread))))) (defvar *do-every-nth-table* (make-hash-table)) (defvar *do-every-nth-lock* (make-mutex :name "do-every-nth")) (defun counter-value (id) (with-mutex (*do-every-nth-lock*) (let ((v (gethash id *do-every-nth-table*))) (setf (gethash id *do-every-nth-table*) (if v (1+ v) 1))))) (defmacro every-nth-time (n &body body) (let ((id (gensym))) `(when (zerop (mod (counter-value ',id) ,n)) ,@body))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Miscellaneous ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun force-format (str &rest args) "force-format STREAM &rest ARGS. Like format, except flushes output on the stream." (apply #'format str args) (finish-output str)) (defparameter *standard-equality-tests* (list #'eq #'equal #'eql #'equalp 'eq 'eql 'equal 'equalp)) (defun is-standard-equality-test (f) (member f *standard-equality-tests*)) (defun filter (f l) (loop for x in l when (funcall f x) collect x))