mirror of
https://github.com/paparazzi/paparazzi.git
synced 2026-05-20 02:53:15 +08:00
Merge branch 'dev' into locm3
This commit is contained in:
Piotr Esden-Tempski
+10
@@ -170,3 +170,13 @@
|
||||
|
||||
# Mac OS X
|
||||
.DS_Store
|
||||
|
||||
sw/ground_segment/lpc21iap/lpc21iap.dSYM/Contents/Info.plist
|
||||
|
||||
sw/ground_segment/lpc21iap/lpc21iap.dSYM/Contents/Resources/DWARF/lpc21iap
|
||||
|
||||
tests/results/*
|
||||
|
||||
sw/logalizer/plotprofile.dSYM/Contents/Resources/DWARF/plotprofile
|
||||
|
||||
sw/logalizer/plotprofile.dSYM/Contents/Info.plist
|
||||
|
||||
@@ -243,6 +243,7 @@ clean:
|
||||
$(Q)make -C sw/ext clean
|
||||
$(Q)find . -name '*~' -exec rm -f {} \;
|
||||
$(Q)rm -f paparazzi sw/simulator/launchsitl
|
||||
$(Q)rm -rf tests/results/*
|
||||
|
||||
cleanspaces:
|
||||
find ./sw/airborne -name '*.[ch]' -exec sed -i {} -e 's/[ \t]*$$//' \;
|
||||
@@ -263,9 +264,6 @@ dist_clean_irreversible: clean
|
||||
ab_clean:
|
||||
find sw/airborne -name '*~' -exec rm -f {} \;
|
||||
|
||||
test_all_example_airframes: replace_current_conf_xml
|
||||
for ap in `grep name conf/conf.xml.example | sed -e 's/.*name=\"//' | sed -e 's/".*//'`; do for airframe in `grep $$ap conf/conf.xml.example | sed -e 's/.*airframe=\"//' | sed -e 's/".*//'`; do for target in `grep target conf/$$airframe | grep name | sed -e 's/.*name=\"//' | sed -e 's/\".*//'`; do echo "Making $$ap $$target"; make -C ./ AIRCRAFT=$$ap clean_ac $$target.compile || exit 1; done; done; done
|
||||
|
||||
replace_current_conf_xml:
|
||||
test conf/conf.xml || mv conf/conf.xml conf/conf.xml.backup.`date +%Y%m%d-%H%M%s`
|
||||
cp conf/conf.xml.example conf/conf.xml
|
||||
@@ -280,4 +278,9 @@ sw/simulator/launchsitl:
|
||||
cat src/$(@F) | sed s#OCAMLRUN#$(OCAMLRUN)# | sed s#OCAML#$(OCAML)# > $@
|
||||
chmod a+x $@
|
||||
|
||||
test: all replace_current_conf_xml
|
||||
cd tests; $(MAKE) $(@)
|
||||
|
||||
test_all_example_airframes: replace_current_conf_xml
|
||||
cd tests; $(MAKE) $(@) TARGET_BOARD=examples
|
||||
|
||||
|
||||
+4
-1
@@ -78,6 +78,9 @@ OOCD = $(shell if test -e $(TOOLCHAIN_DIR)/bin/openocd ; then echo $(TOOLCHAIN_D
|
||||
endif
|
||||
endif
|
||||
|
||||
ifneq ($(BOARD_SERIAL),)
|
||||
OOCD_OPTIONS = -c "ft2232_serial $(BOARD_SERIAL)"
|
||||
endif
|
||||
|
||||
LOADER=/home/poine/work/stm32/stm32loader-a3c51c26ad6c/stm32loader.py
|
||||
|
||||
@@ -257,7 +260,7 @@ upload: $(OBJDIR)/$(TARGET).elf
|
||||
@echo "Using OOCD = $(OOCD)"
|
||||
@echo " OOCD\t$<"
|
||||
$(Q)$(OOCD) -f interface/$(OOCD_INTERFACE).cfg \
|
||||
-f board/$(OOCD_BOARD).cfg \
|
||||
-f board/$(OOCD_BOARD).cfg $(OOCD_OPTIONS) \
|
||||
-c init \
|
||||
-c "reset halt" \
|
||||
-c "reset init" \
|
||||
|
||||
@@ -1,2 +1,192 @@
|
||||
<!--
|
||||
This airframe is connected to the build server and is used for hardware testing.
|
||||
The hardware configuration is
|
||||
Powered via a plug 12V pack
|
||||
Lisa/L v1.1 board
|
||||
XBee connected to UART2 configured at 38400
|
||||
Aspirin v1.5
|
||||
overo
|
||||
-->
|
||||
<airframe name="TestConfig">
|
||||
<firmware name="fixedwing">
|
||||
<target name="sim" board="pc"/>
|
||||
<target name="ap" board="lisa_l_1.1">
|
||||
<configure name="PERIODIC_FREQUENCY" value="120"/>
|
||||
</target>
|
||||
|
||||
<subsystem name="radio_control" type="ppm"/>
|
||||
<subsystem name="telemetry" type="xbee_api">
|
||||
<configure name="MODEM_BAUD" value="B38400"/>
|
||||
</subsystem>
|
||||
<subsystem name="control"/>
|
||||
<subsystem name="imu" type="ppzuav"/>
|
||||
<subsystem name="ahrs" type="float_dcm"/>
|
||||
<subsystem name="navigation"/>
|
||||
</firmware>
|
||||
|
||||
<servos>
|
||||
<servo name="MOTOR" no="0" min="1000" neutral="1000" max="2000"/>
|
||||
<servo name="AILEVON_LEFT" no="1" min="1900" neutral="1534" max="1100"/>
|
||||
<servo name="AILEVON_RIGHT" no="2" min="1100" neutral="1468" max="1900"/>
|
||||
</servos>
|
||||
|
||||
<commands>
|
||||
<axis name="THROTTLE" failsafe_value="0"/>
|
||||
<axis name="ROLL" failsafe_value="0"/>
|
||||
<axis name="PITCH" failsafe_value="0"/>
|
||||
</commands>
|
||||
|
||||
<rc_commands>
|
||||
<set command="THROTTLE" value="@THROTTLE"/>
|
||||
<set command="ROLL" value="@ROLL"/>
|
||||
<set command="PITCH" value="@PITCH"/>
|
||||
</rc_commands>
|
||||
|
||||
<section name="MIXER">
|
||||
<define name="AILEVON_AILERON_RATE" value="0.45"/>
|
||||
<define name="AILEVON_ELEVATOR_RATE" value="0.8"/>
|
||||
</section>
|
||||
|
||||
<command_laws>
|
||||
<let var="aileron" value="@ROLL * AILEVON_AILERON_RATE"/>
|
||||
<let var="elevator" value="@PITCH * AILEVON_ELEVATOR_RATE"/>
|
||||
<set servo="MOTOR" value="@THROTTLE"/>
|
||||
<set servo="AILEVON_LEFT" value="$elevator + $aileron"/>
|
||||
<set servo="AILEVON_RIGHT" value="$elevator - $aileron"/>
|
||||
</command_laws>
|
||||
|
||||
<section name="AUTO1" prefix="AUTO1_">
|
||||
<define name="MAX_ROLL" value="50" unit="deg"/>
|
||||
<define name="MAX_PITCH" value="35" unit="deg"/>
|
||||
</section>
|
||||
|
||||
<section name="BAT">
|
||||
<define name="LOW_BAT_LEVEL" value="10.5" unit="V"/>
|
||||
<define name="CRITIC_BAT_LEVEL" value="10" unit="V"/>
|
||||
<define name="CATASTROPHIC_BAT_LEVEL" value="9.1" unit="V"/>
|
||||
</section>
|
||||
|
||||
<section name="FAILSAFE" prefix="FAILSAFE_">
|
||||
<define name="DELAY_WITHOUT_GPS" value="2" unit="s"/>
|
||||
<define name="DEFAULT_THROTTLE" value="0.3" unit="%"/>
|
||||
<define name="DEFAULT_ROLL" value="0.3" unit="rad"/>
|
||||
<define name="DEFAULT_PITCH" value="0.5" unit="rad"/>
|
||||
<define name="HOME_RADIUS" value="100" unit="m"/>
|
||||
</section>
|
||||
|
||||
<section name="MISC">
|
||||
<define name="NOMINAL_AIRSPEED" value="13." unit="m/s"/>
|
||||
<define name="CARROT" value="5." unit="s"/>
|
||||
<define name="CONTROL_RATE" value="60" unit="Hz"/>
|
||||
<define name="XBEE_INIT" value=""ATPL2\rATRN5\rATTT80\r""/>
|
||||
<!-- <define name="NO_XBEE_API_INIT" value="TRUE"/> -->
|
||||
<define name="ALT_KALMAN_ENABLED" value="TRUE"/>
|
||||
<define name="DEFAULT_CIRCLE_RADIUS" value="80."/>
|
||||
</section>
|
||||
|
||||
<!-- Local magnetic field -->
|
||||
<section name="AHRS" prefix="AHRS_" >
|
||||
<define name="H_X" value="0.51562740288882" />
|
||||
<define name="H_Y" value="-0.05707735220832" />
|
||||
<define name="H_Z" value="0.85490967783446" />
|
||||
</section>
|
||||
|
||||
<section name="IMU" prefix="IMU_">
|
||||
<!-- Calibration Neutral -->
|
||||
<define name="GYRO_P_NEUTRAL" value="0"/>
|
||||
<define name="GYRO_Q_NEUTRAL" value="0"/>
|
||||
<define name="GYRO_R_NEUTRAL" value="0"/>
|
||||
|
||||
<!-- SENS = 14.375 LSB/(deg/sec) * 57.6 deg/rad = 828 LSB/rad/sec / 12bit FRAC: 4096 / 828 -->
|
||||
<define name="GYRO_P_SENS" value="4.947" integer="16"/>
|
||||
<define name="GYRO_Q_SENS" value="4.947" integer="16"/>
|
||||
<define name="GYRO_R_SENS" value="4.947" integer="16"/>
|
||||
|
||||
<define name="GYRO_P_Q" value="0."/>
|
||||
<define name="GYRO_P_R" value="0"/>
|
||||
<define name="GYRO_Q_P" value="0."/>
|
||||
<define name="GYRO_Q_R" value="0."/>
|
||||
<define name="GYRO_R_P" value="0."/>
|
||||
<define name="GYRO_R_Q" value="0."/>
|
||||
|
||||
<define name="GYRO_P_SIGN" value="1"/>
|
||||
<define name="GYRO_Q_SIGN" value="1"/>
|
||||
<define name="GYRO_R_SIGN" value="1"/>
|
||||
|
||||
<define name="ACCEL_X_NEUTRAL" value="-14"/>
|
||||
<define name="ACCEL_Y_NEUTRAL" value="0"/>
|
||||
<define name="ACCEL_Z_NEUTRAL" value="0"/>
|
||||
|
||||
<!-- SENS = 256 LSB/g @ 2.5V [X&Y: 265 LSB/g @ 3.3V] / 9.81 ms2/g = 26.095 LSB/ms2 / 10bit FRAC: 1024 / 26.095 for z and 1024 / 27.01 for X&Y -->
|
||||
<define name="ACCEL_X_SENS" value="37.9" integer="16"/>
|
||||
<define name="ACCEL_Y_SENS" value="37.9" integer="16"/>
|
||||
<define name="ACCEL_Z_SENS" value="39.24" integer="16"/>
|
||||
|
||||
<define name="ACCEL_X_SIGN" value="1"/>
|
||||
<define name="ACCEL_Y_SIGN" value="1"/>
|
||||
<define name="ACCEL_Z_SIGN" value="1"/>
|
||||
|
||||
<define name="MAG_X_NEUTRAL" value="0"/>
|
||||
<define name="MAG_Y_NEUTRAL" value="0"/>
|
||||
<define name="MAG_Z_NEUTRAL" value="0"/>
|
||||
|
||||
<define name="MAG_X_SENS" value="1" integer="16"/>
|
||||
<define name="MAG_Y_SENS" value="1" integer="16"/>
|
||||
<define name="MAG_Z_SENS" value="1" integer="16"/>
|
||||
|
||||
<define name="MAG_X_SIGN" value="1"/>
|
||||
<define name="MAG_Y_SIGN" value="1"/>
|
||||
<define name="MAG_Z_SIGN" value="1"/>
|
||||
|
||||
<define name="BODY_TO_IMU_PHI" value="0"/>
|
||||
<define name="BODY_TO_IMU_THETA" value="0"/>
|
||||
<define name="BODY_TO_IMU_PSI" value="0"/>
|
||||
</section>
|
||||
|
||||
<section name="INS" prefix="INS_">
|
||||
<define name="ROLL_NEUTRAL_DEFAULT" value="0" unit="deg"/>
|
||||
<define name="PITCH_NEUTRAL_DEFAULT" value="0" unit="deg"/>
|
||||
</section>
|
||||
|
||||
<section name="VERTICAL CONTROL" prefix="V_CTL_">
|
||||
<define name="POWER_CTL_BAT_NOMINAL" value="11.1" unit="volt"/>
|
||||
<!-- outer loop proportional gain -->
|
||||
<define name="ALTITUDE_PGAIN" value="-0.03"/>
|
||||
<!-- outer loop saturation -->
|
||||
<define name="ALTITUDE_MAX_CLIMB" value="2."/>
|
||||
|
||||
<!-- auto throttle inner loop -->
|
||||
<define name="AUTO_THROTTLE_NOMINAL_CRUISE_THROTTLE" value="0.32"/>
|
||||
<define name="AUTO_THROTTLE_MIN_CRUISE_THROTTLE" value="0.25"/>
|
||||
<define name="AUTO_THROTTLE_MAX_CRUISE_THROTTLE" value="0.65"/>
|
||||
<define name="AUTO_THROTTLE_LOITER_TRIM" value="1500"/>
|
||||
<define name="AUTO_THROTTLE_DASH_TRIM" value="-4000"/>
|
||||
<define name="AUTO_THROTTLE_CLIMB_THROTTLE_INCREMENT" value="0.15" unit="%/(m/s)"/>
|
||||
<define name="AUTO_THROTTLE_PGAIN" value="-0.01"/>
|
||||
<define name="AUTO_THROTTLE_IGAIN" value="0.1"/>
|
||||
<define name="AUTO_THROTTLE_PITCH_OF_VZ_PGAIN" value="0.05"/>
|
||||
|
||||
<define name="THROTTLE_SLEW_LIMITER" value="2" unit="s"/>
|
||||
</section>
|
||||
|
||||
<section name="HORIZONTAL CONTROL" prefix="H_CTL_">
|
||||
<define name="COURSE_PGAIN" value="-1.20000004768"/>
|
||||
<define name="COURSE_DGAIN" value="0.3"/>
|
||||
<define name="COURSE_PRE_BANK_CORRECTION" value="0.2"/>
|
||||
|
||||
<define name="ROLL_MAX_SETPOINT" value="0.75" unit="rad"/>
|
||||
<define name="PITCH_MAX_SETPOINT" value="0.5" unit="rad"/>
|
||||
<define name="PITCH_MIN_SETPOINT" value="-0.5" unit="rad"/>
|
||||
|
||||
<define name="PITCH_PGAIN" value="-12000."/>
|
||||
<define name="PITCH_DGAIN" value="1.5"/>
|
||||
|
||||
<define name="ELEVATOR_OF_ROLL" value="1000."/>
|
||||
|
||||
<define name="ROLL_SLEW" value="1."/>
|
||||
|
||||
<define name="ROLL_ATTITUDE_GAIN" value="-7500"/>
|
||||
<define name="ROLL_RATE_GAIN" value="0."/>
|
||||
</section>
|
||||
|
||||
</airframe>
|
||||
|
||||
@@ -1,2 +1,23 @@
|
||||
<!--
|
||||
This airframe is connected to the build server and is used for hardware testing.
|
||||
The hardware configuration is
|
||||
Powered via a plug 12V pack
|
||||
Lisa/L v1.1 board
|
||||
XBee connected to UART2 configured at 38400
|
||||
Aspirin v1.5
|
||||
overo
|
||||
-->
|
||||
<airframe name="TestConfig">
|
||||
<firmware name="rotorcraft">
|
||||
<target name="sim" board="pc"/>
|
||||
<target name="ap" board="lisa_l_1.1"/>
|
||||
|
||||
<subsystem name="radio_control" type="ppm"/>
|
||||
<subsystem name="telemetry" type="xbee_api">
|
||||
<configure name="MODEM_BAUD" value="B38400"/>
|
||||
</subsystem>
|
||||
<subsystem name="control"/>
|
||||
<subsystem name="navigation"/>
|
||||
</firmware>
|
||||
|
||||
</airframe>
|
||||
|
||||
@@ -1,2 +1,60 @@
|
||||
<!--
|
||||
This airframe is connected to the build server and is used for hardware testing.
|
||||
The hardware configuration is
|
||||
Powered via a plug 12V pack
|
||||
Lisa/L v1.1 board
|
||||
XBee connected to UART2 configured at 38400
|
||||
Booz2 v1.2
|
||||
GPS connected to UART1 (Since this is inside in a metal box it won't ever get a solution)
|
||||
-->
|
||||
<airframe name="TestConfig">
|
||||
<firmware name="fixedwing">
|
||||
<target name="sim" board="pc"/>
|
||||
<target name="ap" board="lisa_l_1.1"/>
|
||||
|
||||
<subsystem name="radio_control" type="ppm"/>
|
||||
<subsystem name="telemetry" type="xbee_api">
|
||||
<configure name="MODEM_BAUD" value="B38400"/>
|
||||
</subsystem>
|
||||
<subsystem name="control"/>
|
||||
<subsystem name="gps" type="ublox"/>
|
||||
<subsystem name="navigation"/>
|
||||
</firmware>
|
||||
|
||||
<servos>
|
||||
<servo name="MOTOR" no="0" min="1000" neutral="1000" max="2000"/>
|
||||
<servo name="AILEVON_LEFT" no="1" min="1900" neutral="1534" max="1100"/>
|
||||
<servo name="AILEVON_RIGHT" no="2" min="1100" neutral="1468" max="1900"/>
|
||||
</servos>
|
||||
|
||||
<commands>
|
||||
<axis name="THROTTLE" failsafe_value="0"/>
|
||||
<axis name="ROLL" failsafe_value="0"/>
|
||||
<axis name="PITCH" failsafe_value="0"/>
|
||||
</commands>
|
||||
|
||||
<rc_commands>
|
||||
<set command="THROTTLE" value="@THROTTLE"/>
|
||||
<set command="ROLL" value="@ROLL"/>
|
||||
<set command="PITCH" value="@PITCH"/>
|
||||
</rc_commands>
|
||||
|
||||
<section name="MIXER">
|
||||
<define name="AILEVON_AILERON_RATE" value="0.45"/>
|
||||
<define name="AILEVON_ELEVATOR_RATE" value="0.8"/>
|
||||
</section>
|
||||
|
||||
<command_laws>
|
||||
<let var="aileron" value="@ROLL * AILEVON_AILERON_RATE"/>
|
||||
<let var="elevator" value="@PITCH * AILEVON_ELEVATOR_RATE"/>
|
||||
<set servo="MOTOR" value="@THROTTLE"/>
|
||||
<set servo="AILEVON_LEFT" value="$elevator + $aileron"/>
|
||||
<set servo="AILEVON_RIGHT" value="$elevator - $aileron"/>
|
||||
</command_laws>
|
||||
|
||||
<section name="AUTO1" prefix="AUTO1_">
|
||||
<define name="MAX_ROLL" value="50" unit="deg"/>
|
||||
<define name="MAX_PITCH" value="35" unit="deg"/>
|
||||
</section>
|
||||
|
||||
</airframe>
|
||||
|
||||
@@ -1,2 +1,303 @@
|
||||
<!--
|
||||
This airframe is connected to the build server and is used for hardware testing.
|
||||
The hardware configuration is
|
||||
Powered via a plug 12V pack
|
||||
Lisa/L v1.1 board
|
||||
XBee connected to UART2 configured at 38400
|
||||
Booz2 v1.2
|
||||
GPS connected to UART1 (Since this is inside in a metal box it won't ever get a solution)
|
||||
-->
|
||||
<airframe name="TestConfig">
|
||||
<!--
|
||||
<firmware name="rotorcraft">
|
||||
<target name="sim" board="pc"/>
|
||||
<target name="ap" board="lisa_l_1.1"/>
|
||||
|
||||
<subsystem name="radio_control" type="ppm"/>
|
||||
<subsystem name="telemetry" type="xbee_api">
|
||||
<configure name="MODEM_BAUD" value="B38400"/>
|
||||
</subsystem>
|
||||
<subsystem name="control"/>
|
||||
<subsystem name="gps" type="ublox"/>
|
||||
<subsystem name="imu" type="b2_v1.2"/>
|
||||
<subsystem name="stabilization" type="euler"/>
|
||||
<subsystem name="ahrs" type="int_cmpl_quat"/>
|
||||
<subsystem name="navigation"/>
|
||||
</firmware>
|
||||
-->
|
||||
|
||||
<firmware name="rotorcraft">
|
||||
<target name="ap" board="lisa_l_1.1">
|
||||
<!--define name="NO_RC_THRUST_LIMIT"/-->
|
||||
<subsystem name="radio_control" type="spektrum"/>
|
||||
<define name="RADIO_MODE" value="RADIO_AUX1"/>
|
||||
<define name="RADIO_KILL_SWITCH" value="RADIO_GEAR"/>
|
||||
<define name ="RADIO_CONTROL_SPEKTRUM_SECONDARY_PORT" value = "UART5"/>
|
||||
<define name ="OVERRIDE_UART5_IRQ_HANDLER"/>
|
||||
<subsystem name="actuators" type="mkk"/>
|
||||
<subsystem name="telemetry" type="transparent"/>
|
||||
</target>
|
||||
|
||||
<target name="sim" board="pc">
|
||||
<subsystem name="fdm" type="nps"/>
|
||||
<subsystem name="radio_control" type="ppm"/>
|
||||
<subsystem name="actuators" type="mkk"/>
|
||||
</target>
|
||||
|
||||
<subsystem name="imu" type="b2_v1.2"/>
|
||||
<subsystem name="gps" type="ublox">
|
||||
<configure name="GPS_BAUD" value="B57600"/>
|
||||
</subsystem>
|
||||
<subsystem name="stabilization" type="euler"/>
|
||||
<subsystem name="ahrs" type="int_cmpl_quat"/>
|
||||
</firmware>
|
||||
|
||||
<!--
|
||||
<firmware name="lisa_test_progs">
|
||||
<target name="test_led" board="lisa_l_1.1"/>
|
||||
<target name="test_uart" board="lisa_l_1.1"/>
|
||||
<target name="test_servos" board="lisa_l_1.1"/>
|
||||
<target name="test_telemetry" board="lisa_l_1.1"/>
|
||||
<target name="test_baro" board="lisa_l_1.1"/>
|
||||
<target name="test_imu_b2" board="lisa_l_1.1"/>
|
||||
<target name="test_imu_b2_2" board="lisa_l_1.1"/>
|
||||
<target name="test_imu_aspirin" board="lisa_l_1.1"/>
|
||||
<target name="test_rc_spektrum" board="lisa_l_1.1"/>
|
||||
<target name="test_rc_ppm" board="lisa_l_1.1"/>
|
||||
<target name="test_adc" board="lisa_l_1.1"/>
|
||||
<target name="test_hmc5843" board="lisa_l_1.1"/>
|
||||
<target name="test_itg3200" board="lisa_l_1.1"/>
|
||||
<target name="test_adxl345" board="lisa_l_1.1"/>
|
||||
<target name="test_esc_mkk_simple" board="lisa_l_1.1"/>
|
||||
<target name="test_esc_asctecv1_simple" board="lisa_l_1.1"/>
|
||||
<target name="test_actuators_mkk" board="lisa_l_1.1"/>
|
||||
<target name="test_actuators_asctecv1" board="lisa_l_1.1"/>
|
||||
</firmware>
|
||||
|
||||
<firmware name="lisa_passthrough">
|
||||
<target name="overo_test_passthrough" board="lisa_l_1.1" >
|
||||
<configure name="HOST" value="A7"/>
|
||||
<configure name="USER" value=""/>
|
||||
<configure name="TARGET_DIR" value="~"/>
|
||||
<configure name="PERIODIC_FREQ" value="512"/>
|
||||
</target>
|
||||
<target name="stm_passthrough" board="lisa_l_1.1">
|
||||
<subsystem name="radio_control" type="spektrum"/>
|
||||
<subsystem name="imu" type="b2_v1.2"/>
|
||||
</target>
|
||||
</firmware>
|
||||
-->
|
||||
|
||||
<servos min="0" neutral="0" max="0xff">
|
||||
<servo name="FRONT" no="0" min="0" neutral="0" max="255"/>
|
||||
<servo name="BACK" no="1" min="0" neutral="0" max="255"/>
|
||||
<servo name="RIGHT" no="2" min="0" neutral="0" max="255"/>
|
||||
<servo name="LEFT" no="3" min="0" neutral="0" max="255"/>
|
||||
</servos>
|
||||
|
||||
<commands>
|
||||
<axis name="PITCH" failsafe_value="0"/>
|
||||
<axis name="ROLL" failsafe_value="0"/>
|
||||
<axis name="YAW" failsafe_value="0"/>
|
||||
<axis name="THRUST" failsafe_value="0"/>
|
||||
</commands>
|
||||
|
||||
<!-- for the sim -->
|
||||
<section name="ACTUATORS_MKK" prefix="ACTUATORS_MKK_">
|
||||
<define name="NB" value="4"/>
|
||||
<define name="ADDR" value="{ 0x52, 0x54, 0x56, 0x58 }"/>
|
||||
</section>
|
||||
|
||||
|
||||
<section name="SUPERVISION" prefix="SUPERVISION_">
|
||||
<define name="MIN_MOTOR" value="2"/>
|
||||
<define name="MAX_MOTOR" value="210"/>
|
||||
<define name="TRIM_A" value="0"/>
|
||||
<define name="TRIM_E" value="0"/>
|
||||
<define name="TRIM_R" value="0"/>
|
||||
<define name="NB_MOTOR" value="4"/>
|
||||
<define name="SCALE" value="256"/>
|
||||
<define name="ROLL_COEF" value="{ 0, 0, -256, 256 }"/>
|
||||
<define name="PITCH_COEF" value="{ 256, -256, 0, 0 }"/>
|
||||
<define name="YAW_COEF" value="{ -256, -256, 256, 256 }"/>
|
||||
<define name="THRUST_COEF" value="{ 256, 256, 256, 256 }"/>
|
||||
</section>
|
||||
|
||||
<section name="IMU" prefix="IMU_">
|
||||
<define name="GYRO_P_NEUTRAL" value="32581"/>
|
||||
<define name="GYRO_Q_NEUTRAL" value="32008"/>
|
||||
<define name="GYRO_R_NEUTRAL" value="33207"/>
|
||||
<define name="GYRO_P_SENS" value=".903" integer="16"/>
|
||||
<define name="GYRO_Q_SENS" value=".905" integer="16"/>
|
||||
<define name="GYRO_R_SENS" value=".893" integer="16"/>
|
||||
<define name="GYRO_PQ_SENS" value="0.0" integer="16"/>
|
||||
<define name="GYRO_PR_SENS" value="0.0" integer="16"/>
|
||||
<define name="GYRO_QR_SENS" value="0.0" integer="16"/>
|
||||
|
||||
<define name="ACCEL_X_NEUTRAL" value="25950"/>
|
||||
<define name="ACCEL_Y_NEUTRAL" value="26351"/>
|
||||
<define name="ACCEL_Z_NEUTRAL" value="25696"/>
|
||||
<define name="ACCEL_X_SENS" value="1.86342150011" integer="16"/>
|
||||
<define name="ACCEL_Y_SENS" value="1.88378993899" integer="16"/>
|
||||
<define name="ACCEL_Z_SENS" value="1.86557913201" integer="16"/>
|
||||
<define name="ACCEL_XY_SENS" value="0.0" integer="16"/>
|
||||
<define name="ACCEL_XZ_SENS" value="0.0" integer="16"/>
|
||||
<define name="ACCEL_YZ_SENS" value="0.0" integer="16"/>
|
||||
|
||||
<define name="MAG_X_NEUTRAL" value="0"/>
|
||||
<define name="MAG_Y_NEUTRAL" value="0"/>
|
||||
<define name="MAG_Z_NEUTRAL" value="0"/>
|
||||
<define name="MAG_X_SENS" value="1." integer="16"/>
|
||||
<define name="MAG_Y_SENS" value="1." integer="16"/>
|
||||
<define name="MAG_Z_SENS" value="1." integer="16"/>
|
||||
<define name="MAG_XY_SENS" value="0.0" integer="16"/>
|
||||
<define name="MAG_XZ_SENS" value="0.0" integer="16"/>
|
||||
<define name="MAG_YZ_SENS" value="0.0" integer="16"/>
|
||||
|
||||
<define name="BODY_TO_IMU_PHI" value="0." unit="deg"/>
|
||||
<define name="BODY_TO_IMU_THETA" value="0." unit="deg"/>
|
||||
<define name="BODY_TO_IMU_PSI" value="0." unit="deg"/>
|
||||
|
||||
</section>
|
||||
|
||||
<section name="AUTOPILOT">
|
||||
<define name="MODE_AUTO1" value="AP_MODE_ATTITUDE_DIRECT"/>
|
||||
<define name="MODE_MANUAL" value="AP_MODE_ATTITUDE_Z_HOLD"/>
|
||||
<define name="MODE_AUTO2" value="AP_MODE_HOVER_Z_HOLD"/>
|
||||
</section>
|
||||
|
||||
<section name="BAT">
|
||||
<define name="CATASTROPHIC_BAT_LEVEL" value="12.4" unit="V"/>
|
||||
<define name="MAX_BAT_LEVEL" value="16.8" unit="V" />
|
||||
<define name="CRITIC_BAT_LEVEL" value="13.0" unit="V" />
|
||||
<define name="LOW_BAT_LEVEL" value="14.0" unit="V" />
|
||||
</section>
|
||||
|
||||
<section name="STABILIZATION_RATE" prefix="STABILIZATION_RATE_">
|
||||
|
||||
<define name="SP_MAX_P" value="10000"/>
|
||||
<define name="SP_MAX_Q" value="10000"/>
|
||||
<define name="SP_MAX_R" value="10000"/>
|
||||
|
||||
<define name="GAIN_P" value="-400"/>
|
||||
<define name="GAIN_Q" value="-400"/>
|
||||
<define name="GAIN_R" value="-350"/>
|
||||
|
||||
</section>
|
||||
|
||||
<section name="STABILIZATION_ATTITUDE" prefix="STABILIZATION_ATTITUDE_">
|
||||
|
||||
<!-- setpoints -->
|
||||
<define name="SP_MAX_PHI" value="45." unit="deg"/>
|
||||
<define name="SP_MAX_THETA" value="45." unit="deg"/>
|
||||
<define name="SP_MAX_R" value="90." unit="deg/s"/>
|
||||
<define name="DEADBAND_R" value="250"/>
|
||||
|
||||
<!-- reference -->
|
||||
<define name="REF_OMEGA_P" value="800" unit="deg/s"/>
|
||||
<define name="REF_ZETA_P" value="0.9"/>
|
||||
<define name="REF_MAX_P" value="300." unit="deg/s"/>
|
||||
<define name="REF_MAX_PDOT" value="RadOfDeg(7000.)"/>
|
||||
|
||||
<define name="REF_OMEGA_Q" value="800" unit="deg/s"/>
|
||||
<define name="REF_ZETA_Q" value="0.9"/>
|
||||
<define name="REF_MAX_Q" value="300." unit="deg/s"/>
|
||||
<define name="REF_MAX_QDOT" value="RadOfDeg(7000.)"/>
|
||||
|
||||
<define name="REF_OMEGA_R" value="500" unit="deg/s"/>
|
||||
<define name="REF_ZETA_R" value="0.9"/>
|
||||
<define name="REF_MAX_R" value="180." unit="deg/s"/>
|
||||
<define name="REF_MAX_RDOT" value="RadOfDeg(1800.)"/>
|
||||
|
||||
<!--
|
||||
<define name="PHI_PGAIN" value="-2000"/>
|
||||
<define name="PHI_DGAIN" value="-400"/>
|
||||
<define name="PHI_IGAIN" value="-200"/>
|
||||
|
||||
<define name="THETA_PGAIN" value="-2000"/>
|
||||
<define name="THETA_DGAIN" value="-400"/>
|
||||
<define name="THETA_IGAIN" value="-200"/>
|
||||
|
||||
<define name="PSI_PGAIN" value="-2000"/>
|
||||
<define name="PSI_DGAIN" value="-400"/>
|
||||
<define name="PSI_IGAIN" value="-10"/>
|
||||
|
||||
|
||||
<define name="PHI_DDGAIN" value=" 300"/>
|
||||
<define name="THETA_DDGAIN" value=" 300"/>
|
||||
<define name="PSI_DDGAIN" value=" 300"/>
|
||||
-->
|
||||
|
||||
<!-- feedback -->
|
||||
<define name="PHI_PGAIN" value="-900"/>
|
||||
<define name="PHI_DGAIN" value="-200"/>
|
||||
<define name="PHI_IGAIN" value="-200"/>
|
||||
|
||||
<define name="THETA_PGAIN" value="-900"/>
|
||||
<define name="THETA_DGAIN" value="-200"/>
|
||||
<define name="THETA_IGAIN" value="-200"/>
|
||||
|
||||
<define name="PSI_PGAIN" value="-900"/>
|
||||
<define name="PSI_DGAIN" value="-200"/>
|
||||
<define name="PSI_IGAIN" value="-10"/>
|
||||
|
||||
<!-- feedforward -->
|
||||
<define name="PHI_DDGAIN" value=" 200"/>
|
||||
<define name="THETA_DDGAIN" value=" 200"/>
|
||||
<define name="PSI_DDGAIN" value=" 200"/>
|
||||
|
||||
</section>
|
||||
|
||||
<section name="AHRS" prefix="AHRS_">
|
||||
<define name="PROPAGATE_FREQUENCY" value="512"/>
|
||||
<define name="H_X" value=" 0.3723657"/>
|
||||
<define name="H_Y" value=" 0.1515225"/>
|
||||
<define name="H_Z" value="-0.9156335"/>
|
||||
</section>
|
||||
|
||||
<section name="INS" prefix="INS_">
|
||||
<define name="BARO_SENS" value="10." integer="16"/>
|
||||
</section>
|
||||
|
||||
<section name="GUIDANCE_V" prefix="GUIDANCE_V_">
|
||||
<define name="MIN_ERR_Z" value="POS_BFP_OF_REAL(-10.)"/>
|
||||
<define name="MAX_ERR_Z" value="POS_BFP_OF_REAL( 10.)"/>
|
||||
<define name="MIN_ERR_ZD" value="SPEED_BFP_OF_REAL(-10.)"/>
|
||||
<define name="MAX_ERR_ZD" value="SPEED_BFP_OF_REAL( 10.)"/>
|
||||
<define name="MAX_SUM_ERR" value="2000000"/>
|
||||
<define name="HOVER_KP" value="-150"/>
|
||||
<define name="HOVER_KD" value="-80"/>
|
||||
<define name="HOVER_KI" value="0"/>
|
||||
|
||||
<!--
|
||||
<define name="HOVER_KP" value="-150"/>
|
||||
<define name="HOVER_KD" value="-80"/>
|
||||
<define name="HOVER_KI" value="0"/>
|
||||
-->
|
||||
|
||||
<!-- 1.5m/s for full stick : BOOZ_SPEED_I_OF_F(1.5) / (MAX_PPRZ/2) -->
|
||||
<define name="RC_CLIMB_COEF" value ="163"/>
|
||||
<!-- BOOZ_SPEED_I_OF_F(1.5) * 20% -->
|
||||
<define name="RC_CLIMB_DEAD_BAND" value ="160000"/>
|
||||
<!-- <define name="INV_M" value ="0.2"/> -->
|
||||
</section>
|
||||
|
||||
|
||||
<section name="GUIDANCE_H" prefix="GUIDANCE_H_">
|
||||
<define name="PGAIN" value="-100"/>
|
||||
<define name="DGAIN" value="-100"/>
|
||||
<define name="IGAIN" value="-0"/>
|
||||
<define name="NGAIN" value="-0"/>
|
||||
</section>
|
||||
|
||||
<section name="MISC">
|
||||
<define name="FACE_REINJ_1" value="1024"/>
|
||||
</section>
|
||||
|
||||
<section name="SIMULATOR" prefix="NPS_">
|
||||
<define name="ACTUATOR_NAMES" value="{"front_motor", "back_motor", "right_motor", "left_motor"}"/>
|
||||
<define name="INITIAL_CONDITITONS" value=""reset00""/>
|
||||
<define name="SENSORS_PARAMS" value=""nps_sensors_params_booz2_a1.h""/>
|
||||
</section>
|
||||
|
||||
</airframe>
|
||||
|
||||
+85
-15
@@ -1,22 +1,92 @@
|
||||
<?xml version="1.0"?>
|
||||
|
||||
<conf>
|
||||
<!-- arm7 aircrafts -->
|
||||
|
||||
<!-- NOTE: All targets in the example config need to be on single lines so that the "make test_all_example_airframes" target can build all targets for each aircraft airframe -->
|
||||
<!-- booz2 -->
|
||||
<aircraft
|
||||
name="BOOZ2_A1"
|
||||
ac_id="150"
|
||||
airframe="airframes/Poine/booz2_a1.xml"
|
||||
radio="radios/cockpitSX.xml"
|
||||
telemetry="telemetry/telemetry_booz2.xml"
|
||||
flight_plan="flight_plans/dummy.xml"
|
||||
settings="settings/settings_booz2.xml settings/settings_booz2_ahrs_cmpl.xml"
|
||||
gui_color="white"
|
||||
/>
|
||||
|
||||
<!-- arm7 aircrafts -->
|
||||
<!-- LISA -->
|
||||
<aircraft
|
||||
name="Hexa_LisaL"
|
||||
ac_id="153"
|
||||
airframe="airframes/Poine/h_hex.xml"
|
||||
radio="radios/cockpitSX.xml"
|
||||
telemetry="telemetry/telemetry_booz2.xml"
|
||||
flight_plan="flight_plans/dummy.xml"
|
||||
settings="settings/settings_booz2.xml"
|
||||
gui_color="white"
|
||||
/>
|
||||
<aircraft
|
||||
name="LISA_ASCTEC_PIOTR"
|
||||
ac_id="161"
|
||||
airframe="airframes/esden/lisa_asctec.xml"
|
||||
radio="radios/cockpitSX.xml"
|
||||
telemetry="telemetry/telemetry_booz2.xml"
|
||||
flight_plan="flight_plans/dummy.xml"
|
||||
settings="settings/settings_booz2.xml settings/settings_booz2_ahrs_cmpl.xml"
|
||||
gui_color="white"
|
||||
/>
|
||||
|
||||
<!-- booz2 -->
|
||||
<aircraft name="BOOZ2_A1" ac_id="150" airframe="airframes/Poine/booz2_a1.xml" radio="radios/cockpitSX.xml" telemetry="telemetry/telemetry_booz2.xml" flight_plan="flight_plans/dummy.xml" settings="settings/settings_booz2.xml settings/settings_booz2_ahrs_cmpl.xml" gui_color="white" />
|
||||
|
||||
<!-- LISA -->
|
||||
<aircraft name="Hexa_LisaL" ac_id="153" airframe="airframes/Poine/h_hex.xml" radio="radios/cockpitSX.xml" telemetry="telemetry/telemetry_booz2.xml" flight_plan="flight_plans/dummy.xml" settings="settings/settings_booz2.xml" gui_color="white" />
|
||||
<aircraft name="LISA_ASCTEC_PIOTR" ac_id="161" airframe="airframes/esden/lisa_asctec.xml" radio="radios/cockpitSX.xml" telemetry="telemetry/telemetry_booz2.xml" flight_plan="flight_plans/dummy.xml" settings="settings/settings_booz2.xml settings/settings_booz2_ahrs_cmpl.xml" gui_color="white" />
|
||||
|
||||
<!-- tiny -->
|
||||
<aircraft name="Microjet" ac_id="5" airframe="airframes/microjet_example.xml" radio="radios/cockpitMM.xml" telemetry="telemetry/default.xml" flight_plan="flight_plans/basic.xml" settings="settings/basic_infrared.xml" gui_color="#6293ba" />
|
||||
<aircraft name="Tiny_IMU" ac_id="7" airframe="airframes/example_twog_analogimu.xml" radio="radios/cockpitSX.xml" telemetry="telemetry/default_fixedwing_imu.xml" flight_plan="flight_plans/versatile.xml" settings="settings/tuning_ins.xml" gui_color="blue" />
|
||||
<aircraft name="Twinjet" ac_id="6" airframe="airframes/twinjet_example.xml" radio="radios/cockpitMM.xml" telemetry="telemetry/default.xml" flight_plan="flight_plans/versatile.xml" settings="settings/tuning.xml settings/infrared.xml" gui_color="#ba6293" />
|
||||
<aircraft name="EasyStar_ETS" ac_id="8" airframe="airframes/easystar_ets_example.xml" radio="radios/cockpitSX.xml" telemetry="telemetry/default.xml" flight_plan="flight_plans/versatile.xml" settings="settings/tuning.xml settings/infrared.xml" gui_color="red" />
|
||||
<!-- tiny -->
|
||||
<aircraft
|
||||
name="Microjet"
|
||||
ac_id="5"
|
||||
airframe="airframes/microjet_example.xml"
|
||||
radio="radios/cockpitMM.xml"
|
||||
telemetry="telemetry/default.xml"
|
||||
flight_plan="flight_plans/basic.xml"
|
||||
settings="settings/basic_infrared.xml"
|
||||
gui_color="#6293ba"
|
||||
/>
|
||||
<aircraft
|
||||
name="Tiny_IMU"
|
||||
ac_id="7"
|
||||
airframe="airframes/example_twog_analogimu.xml"
|
||||
radio="radios/cockpitSX.xml"
|
||||
telemetry="telemetry/default_fixedwing_imu.xml"
|
||||
flight_plan="flight_plans/versatile.xml"
|
||||
settings="settings/tuning_ins.xml"
|
||||
gui_color="blue"
|
||||
/>
|
||||
<aircraft
|
||||
name="Twinjet"
|
||||
ac_id="6"
|
||||
airframe="airframes/twinjet_example.xml"
|
||||
radio="radios/cockpitMM.xml"
|
||||
telemetry="telemetry/default.xml"
|
||||
flight_plan="flight_plans/versatile.xml"
|
||||
settings="settings/tuning.xml settings/infrared.xml"
|
||||
gui_color="#ba6293"
|
||||
/>
|
||||
<aircraft
|
||||
name="EasyStar_ETS"
|
||||
ac_id="8"
|
||||
airframe="airframes/easystar_ets_example.xml"
|
||||
radio="radios/cockpitSX.xml"
|
||||
telemetry="telemetry/default.xml"
|
||||
flight_plan="flight_plans/versatile.xml"
|
||||
settings="settings/tuning.xml settings/infrared.xml"
|
||||
gui_color="red"
|
||||
/>
|
||||
|
||||
<!-- Hardware test Lisa/L -->
|
||||
<aircraft
|
||||
name="LisaLv11_Booz2v12_RC"
|
||||
ac_id="9"
|
||||
airframe="airframes/TestHardware/LisaL_v1.1_b2_v1.2_rc.xml"
|
||||
radio="radios/cockpitSX.xml"
|
||||
telemetry="telemetry/telemetry_booz2.xml"
|
||||
flight_plan="flight_plans/dummy.xml"
|
||||
settings="settings/settings_booz2.xml"
|
||||
gui_color="white"
|
||||
/>
|
||||
</conf>
|
||||
|
||||
@@ -0,0 +1,95 @@
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use Test::More tests => 7;
|
||||
use lib "$ENV{'PAPARAZZI_SRC'}/tests/lib";
|
||||
use Program;
|
||||
use Proc::Background;
|
||||
use Ivy;
|
||||
|
||||
$|++;
|
||||
|
||||
####################
|
||||
# Make the airframe
|
||||
my $make_compile_options = "AIRCRAFT=LisaLv11_Booz2v12_RC clean_ac ap.compile";
|
||||
my $compile_output = run_program(
|
||||
"Attempting to build and upload the firmware.",
|
||||
$ENV{'PAPARAZZI_SRC'},
|
||||
"make $make_compile_options",
|
||||
0,1);
|
||||
unlike($compile_output, '/Aircraft \'LisaLv11_Booz2v12_RC\' not found in/', "The compile output does not contain the message \"Aircraft \'LisaLv11_Booz2v12_RC\' not found in\"");
|
||||
unlike($compile_output, '/Error/i', "The compile output does not contain the word \"Error\"");
|
||||
|
||||
####################
|
||||
# Upload the airframe
|
||||
my $make_upload_options = "AIRCRAFT=LisaLv11_Booz2v12_RC BOARD_SERIAL=LISA-L-000156 ap.upload";
|
||||
my $upload_output = run_program(
|
||||
"Attempting to build and upload the firmware.",
|
||||
$ENV{'PAPARAZZI_SRC'},
|
||||
"make $make_upload_options",
|
||||
0,1);
|
||||
unlike($upload_output, '/Error/i', "The upload output does not contain the word \"Error\"");
|
||||
|
||||
# Start the server process
|
||||
my $server_command = "$ENV{'PAPARAZZI_HOME'}/sw/ground_segment/tmtc/server";
|
||||
my $server_options = "";
|
||||
my $server = Proc::Background->new($server_command, $server_options);
|
||||
sleep 2; # The service should die in this time if there's an error
|
||||
ok($server->alive(), "The server started successfully");
|
||||
|
||||
# Start the link process
|
||||
my $link_command = "$ENV{'PAPARAZZI_HOME'}/sw/ground_segment/tmtc/link";
|
||||
my @link_options = qw(-d /dev/tty.usbserial-000013FD -s 57600 -transport xbee -xbee_addr 123);
|
||||
#my @link_options = qw(-d /dev/tty.usbserial-000013FD -s 57600);
|
||||
sleep 2; # The service should die in this time if there's an error
|
||||
my $link = Proc::Background->new($link_command, @link_options);
|
||||
ok($link->alive(), "The link started successfully");
|
||||
|
||||
# Open the Ivy bus and read from it...
|
||||
# TODO: learn how to read and write to the Ivy bus
|
||||
|
||||
# Shutdown the server and link processes
|
||||
ok($server->die(), "The server shutdown successfully.");
|
||||
ok($link->die(), "The link shutdown successfully.");
|
||||
|
||||
################################################################################
|
||||
# functions used by this test script.
|
||||
sub run_program
|
||||
{
|
||||
my $message = shift;
|
||||
my $dir = shift;
|
||||
my $command = shift;
|
||||
my $verbose = shift;
|
||||
my $dont_fail_on_error = shift;
|
||||
|
||||
warn "$message\n" if $verbose;
|
||||
if (defined $dir)
|
||||
{
|
||||
$command = "cd $dir;" . $command;
|
||||
}
|
||||
my $prog = new Program("bash");
|
||||
my $fh = $prog->open("-c \"$command\"");
|
||||
warn "Running command: \"". $prog->last_command() ."\"\n" if $verbose;
|
||||
$fh->autoflush(1);
|
||||
my @output;
|
||||
while (<$fh>)
|
||||
{
|
||||
warn $_ if $verbose;
|
||||
chomp $_;
|
||||
push @output, $_;
|
||||
}
|
||||
$fh->close;
|
||||
my $exit_status = $?/256;
|
||||
unless ($exit_status == 0)
|
||||
{
|
||||
if ($dont_fail_on_error)
|
||||
{
|
||||
warn "Error: The command \"". $prog->last_command() ."\" failed to complete successfully. Exit status: $exit_status\n" if $verbose;
|
||||
}
|
||||
else
|
||||
{
|
||||
die "Error: The command \"". $prog->last_command() ."\" failed to complete successfully. Exit status: $exit_status\n";
|
||||
}
|
||||
}
|
||||
return wantarray ? @output : join "\n", @output;
|
||||
}
|
||||
|
||||
@@ -0,0 +1,19 @@
|
||||
Q = @
|
||||
PERL = /usr/bin/perl
|
||||
TEST_VERBOSE = 0
|
||||
ifeq ($(TARGET_BOARD),)
|
||||
TARGET_BOARD = *
|
||||
endif
|
||||
TEST_FILES := $(shell ls $(TARGET_BOARD)/*.t)
|
||||
|
||||
ifneq ($(JUNIT),)
|
||||
PERLENV=PERL_TEST_HARNESS_DUMP_TAP=$(PAPARAZZI_SRC)/tests/results
|
||||
RUNTESTS=use TAP::Harness; TAP::Harness->new({ formatter_class => 'TAP::Formatter::JUnit', verbosity => $(TEST_VERBOSE), merge => 1, } )->runtests(qw($(TEST_FILES)))
|
||||
else
|
||||
PERLENV=
|
||||
RUNTESTS=use TAP::Harness;TAP::Harness->new( { verbosity => $(TEST_VERBOSE) } )->runtests(qw($(TEST_FILES)))
|
||||
endif
|
||||
|
||||
test:
|
||||
$(Q)$(PERLENV) $(PERL) "-e" "$(RUNTESTS)"
|
||||
|
||||
@@ -0,0 +1,109 @@
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use Test::More;
|
||||
use lib "$ENV{'PAPARAZZI_SRC'}/tests/lib";
|
||||
use XML::Simple;
|
||||
use Program;
|
||||
use Data::Dumper;
|
||||
use Config;
|
||||
|
||||
$|++;
|
||||
my $examples = XMLin("$ENV{'PAPARAZZI_SRC'}/conf/conf.xml.example");
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
ok(1, "Parsed the example file");
|
||||
foreach my $example (sort keys%{$examples->{'aircraft'}})
|
||||
{
|
||||
#next unless $example =~ m#easystar#i;
|
||||
my $airframe = $examples->{'aircraft'}->{$example}->{'airframe'};
|
||||
my $airframe_config = XMLin("$ENV{'PAPARAZZI_SRC'}/conf/$airframe");
|
||||
foreach my $process (sort keys %{$airframe_config->{'firmware'}})
|
||||
{
|
||||
if ($process =~ m#setup|fixedwing|rotorcraft|lisa_test_progs#)
|
||||
{
|
||||
#warn "EX: [$example] ". Dumper($airframe_config->{'firmware'}->{$process}->{'target'});
|
||||
foreach my $target (sort keys %{$airframe_config->{'firmware'}->{$process}->{'target'}})
|
||||
{
|
||||
next unless scalar $airframe_config->{'firmware'}->{$process}->{'target'}->{$target}->{'board'};
|
||||
|
||||
# Exclude some builds on Mac as they are currently broken.
|
||||
next if ( ($Config{'osname'} =~ m#darwin#i) and ($example =~ m#LISA_ASCTEC_PIOTR|LisaLv11_Booz2v12_RC|BOOZ2_A1#i) and ($target =~ m#sim#i) );
|
||||
|
||||
#warn "EXAMPLE: [$example] TARGET: [$target]\n";
|
||||
my $make_upload_options = "AIRCRAFT=$example clean_ac $target.compile";
|
||||
my $upload_output = run_program(
|
||||
"Attempting to build the firmware $target for the airframe $example.",
|
||||
$ENV{'PAPARAZZI_SRC'},
|
||||
"make $make_upload_options",
|
||||
$ENV->{'TEST_VERBOSE'},1);
|
||||
unlike($upload_output, '/Error/i', "The upload output does not contain the word \"Error\"");
|
||||
}
|
||||
}
|
||||
elsif ($process =~ m#target#)
|
||||
{
|
||||
#warn "EXT: [$example] ". Dumper($airframe_config->{'firmware'}->{$process});
|
||||
foreach my $target (sort keys %{$airframe_config->{'firmware'}->{$process}})
|
||||
{
|
||||
next unless scalar $airframe_config->{'firmware'}->{$process}->{$target}->{'board'};
|
||||
|
||||
# Exclude some builds on Mac as they are currently broken.
|
||||
next if ( ($Config{'osname'} =~ m#darwin#i) and ($example =~ m#LISA_ASCTEC_PIOTR|LisaLv11_Booz2v12_RC|BOOZ2_A1#i) and ($target =~ m#sim#i) );
|
||||
|
||||
#warn "EXAMPLET: [$example] TARGET: [$target]\n";
|
||||
my $make_upload_options = "AIRCRAFT=$example clean_ac $target.compile";
|
||||
my $upload_output = run_program(
|
||||
"Attempting to build the firmware $target for the airframe $example.",
|
||||
$ENV{'PAPARAZZI_SRC'},
|
||||
"make $make_upload_options",
|
||||
$ENV->{'TEST_VERBOSE'},1);
|
||||
unlike($upload_output, '/Error/i', "The upload output does not contain the word \"Error\"");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
done_testing();
|
||||
|
||||
################################################################################
|
||||
# functions used by this test script.
|
||||
sub run_program
|
||||
{
|
||||
my $message = shift;
|
||||
my $dir = shift;
|
||||
my $command = shift;
|
||||
my $verbose = shift;
|
||||
my $dont_fail_on_error = shift;
|
||||
|
||||
warn "$message\n" if $verbose;
|
||||
if (defined $dir)
|
||||
{
|
||||
$command = "cd $dir;" . $command;
|
||||
}
|
||||
my $prog = new Program("bash");
|
||||
my $fh = $prog->open("-c \"$command\"");
|
||||
warn "Running command: \"". $prog->last_command() ."\"\n" if $verbose;
|
||||
$fh->autoflush(1);
|
||||
my @output;
|
||||
while (<$fh>)
|
||||
{
|
||||
warn $_ if $verbose;
|
||||
chomp $_;
|
||||
push @output, $_;
|
||||
}
|
||||
$fh->close;
|
||||
my $exit_status = $?/256;
|
||||
unless ($exit_status == 0)
|
||||
{
|
||||
if ($dont_fail_on_error)
|
||||
{
|
||||
warn "Error: The command \"". $prog->last_command() ."\" failed to complete successfully. Exit status: $exit_status\n" if $verbose;
|
||||
}
|
||||
else
|
||||
{
|
||||
die "Error: The command \"". $prog->last_command() ."\" failed to complete successfully. Exit status: $exit_status\n";
|
||||
}
|
||||
}
|
||||
return wantarray ? @output : join "\n", @output;
|
||||
}
|
||||
|
||||
+3091
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,477 @@
|
||||
# Proc::Background: Generic interface to background process management.
|
||||
#
|
||||
# Copyright (C) 1998-2005 Blair Zajac. All rights reserved.
|
||||
|
||||
package Proc::Background;
|
||||
|
||||
require 5.004_04;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use Carp;
|
||||
use Cwd;
|
||||
|
||||
use vars qw(@ISA $VERSION @EXPORT_OK);
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(timeout_system);
|
||||
$VERSION = sprintf '%d.%02d', '$Revision: 1.10 $' =~ /(\d+)\.(\d+)/;
|
||||
|
||||
# Determine if the operating system is Windows.
|
||||
my $is_windows = $^O eq 'MSWin32';
|
||||
|
||||
# Set up a regular expression that tests if the path is absolute and
|
||||
# if it has a directory separator in it. Also create a list of file
|
||||
# extensions of append to the programs name to look for the real
|
||||
# executable.
|
||||
my $is_absolute_re;
|
||||
my $has_dir_element_re;
|
||||
my @extensions = ('');
|
||||
if ($is_windows) {
|
||||
$is_absolute_re = '^(?:(?:[a-zA-Z]:[\\\\/])|(?:[\\\\/]{2}\w+[\\\\/]))';
|
||||
$has_dir_element_re = "[\\\\/]";
|
||||
push(@extensions, '.exe');
|
||||
} else {
|
||||
$is_absolute_re = "^/";
|
||||
$has_dir_element_re = "/";
|
||||
}
|
||||
|
||||
# Make this class a subclass of Proc::Win32 or Proc::Unix. Any
|
||||
# unresolved method calls will go to either of these classes.
|
||||
if ($is_windows) {
|
||||
require Proc::Background::Win32;
|
||||
unshift(@ISA, 'Proc::Background::Win32');
|
||||
} else {
|
||||
require Proc::Background::Unix;
|
||||
unshift(@ISA, 'Proc::Background::Unix');
|
||||
}
|
||||
|
||||
# Take either a relative or absolute path to a command and make it an
|
||||
# absolute path.
|
||||
sub _resolve_path {
|
||||
my $command = shift;
|
||||
|
||||
return unless length $command;
|
||||
|
||||
# Make the path to the progam absolute if it isn't already. If the
|
||||
# path is not absolute and if the path contains a directory element
|
||||
# separator, then only prepend the current working to it. If the
|
||||
# path is not absolute, then look through the PATH environment to
|
||||
# find the executable. In all cases, look for the programs with any
|
||||
# extensions added to the original path name.
|
||||
my $path;
|
||||
if ($command =~ /$is_absolute_re/o) {
|
||||
foreach my $ext (@extensions) {
|
||||
my $p = "$command$ext";
|
||||
if (-f $p and -x _) {
|
||||
$path = $p;
|
||||
last;
|
||||
}
|
||||
}
|
||||
unless (defined $path) {
|
||||
warn "$0: no executable program located at $command\n";
|
||||
}
|
||||
} else {
|
||||
my $cwd = cwd;
|
||||
if ($command =~ /$has_dir_element_re/o) {
|
||||
my $p1 = "$cwd/$command";
|
||||
foreach my $ext (@extensions) {
|
||||
my $p2 = "$p1$ext";
|
||||
if (-f $p2 and -x _) {
|
||||
$path = $p2;
|
||||
last;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
foreach my $dir (split($is_windows ? ';' : ':', $ENV{PATH})) {
|
||||
next unless length $dir;
|
||||
$dir = "$cwd/$dir" unless $dir =~ /$is_absolute_re/o;
|
||||
my $p1 = "$dir/$command";
|
||||
foreach my $ext (@extensions) {
|
||||
my $p2 = "$p1$ext";
|
||||
if (-f $p2 and -x _) {
|
||||
$path = $p2;
|
||||
last;
|
||||
}
|
||||
}
|
||||
last if defined $path;
|
||||
}
|
||||
}
|
||||
unless (defined $path) {
|
||||
warn "$0: cannot find absolute location of $command\n";
|
||||
}
|
||||
}
|
||||
|
||||
$path;
|
||||
}
|
||||
|
||||
# We want the created object to live in Proc::Background instead of
|
||||
# the OS specific class so that generic method calls can be used.
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
||||
my $options;
|
||||
if (@_ and defined $_[0] and UNIVERSAL::isa($_[0], 'HASH')) {
|
||||
$options = shift;
|
||||
}
|
||||
|
||||
unless (@_ > 0) {
|
||||
confess "Proc::Background::new called with insufficient number of arguments";
|
||||
}
|
||||
|
||||
return unless defined $_[0];
|
||||
|
||||
my $self = $class->SUPER::_new(@_) or return;
|
||||
|
||||
# Save the start time of the class.
|
||||
$self->{_start_time} = time;
|
||||
|
||||
# Handle the specific options.
|
||||
if ($options) {
|
||||
$self->{_die_upon_destroy} = $options->{die_upon_destroy};
|
||||
}
|
||||
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
if ($self->{_die_upon_destroy}) {
|
||||
$self->die;
|
||||
}
|
||||
}
|
||||
|
||||
# Reap the child. If the first argument is 0 the wait should return
|
||||
# immediately, 1 if it should wait forever. If this number is
|
||||
# non-zero, then wait. If the wait was sucessful, then delete
|
||||
# $self->{_os_obj} and set $self->{_exit_value} to the OS specific
|
||||
# class return of _reap. Return 1 if we sucessfully waited, 0
|
||||
# otherwise.
|
||||
sub _reap {
|
||||
my $self = shift;
|
||||
my $timeout = shift || 0;
|
||||
|
||||
return 0 unless exists($self->{_os_obj});
|
||||
|
||||
# Try to wait on the process. Use the OS dependent wait call using
|
||||
# the Proc::Background::*::waitpid call, which returns one of three
|
||||
# values.
|
||||
# (0, exit_value) : sucessfully waited on.
|
||||
# (1, undef) : process already reaped and exist value lost.
|
||||
# (2, undef) : process still running.
|
||||
my ($result, $exit_value) = $self->_waitpid($timeout);
|
||||
if ($result == 0 or $result == 1) {
|
||||
$self->{_exit_value} = defined($exit_value) ? $exit_value : 0;
|
||||
delete $self->{_os_obj};
|
||||
# Save the end time of the class.
|
||||
$self->{_end_time} = time;
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub alive {
|
||||
my $self = shift;
|
||||
|
||||
# If $self->{_os_obj} is not set, then the process is definitely
|
||||
# not running.
|
||||
return 0 unless exists($self->{_os_obj});
|
||||
|
||||
# If $self->{_exit_value} is set, then the process has already finished.
|
||||
return 0 if exists($self->{_exit_value});
|
||||
|
||||
# Try to reap the child. If it doesn't reap, then it's alive.
|
||||
!$self->_reap(0);
|
||||
}
|
||||
|
||||
sub wait {
|
||||
my $self = shift;
|
||||
|
||||
# If neither _os_obj or _exit_value are set, then something is wrong.
|
||||
if (!exists($self->{_exit_value}) and !exists($self->{_os_obj})) {
|
||||
return;
|
||||
}
|
||||
|
||||
# If $self->{_exit_value} exists, then we already waited.
|
||||
return $self->{_exit_value} if exists($self->{_exit_value});
|
||||
|
||||
# Otherwise, wait forever for the process to finish.
|
||||
$self->_reap(1);
|
||||
return $self->{_exit_value};
|
||||
}
|
||||
|
||||
sub die {
|
||||
my $self = shift;
|
||||
|
||||
# See if the process has already died.
|
||||
return 1 unless $self->alive;
|
||||
|
||||
# Kill the process using the OS specific method.
|
||||
$self->_die;
|
||||
|
||||
# See if the process is still alive.
|
||||
!$self->alive;
|
||||
}
|
||||
|
||||
sub start_time {
|
||||
$_[0]->{_start_time};
|
||||
}
|
||||
|
||||
sub end_time {
|
||||
$_[0]->{_end_time};
|
||||
}
|
||||
|
||||
sub pid {
|
||||
$_[0]->{_pid};
|
||||
}
|
||||
|
||||
sub timeout_system {
|
||||
unless (@_ > 1) {
|
||||
confess "$0: timeout_system passed too few arguments.\n";
|
||||
}
|
||||
|
||||
my $timeout = shift;
|
||||
unless ($timeout =~ /^\d+(?:\.\d*)?$/ or $timeout =~ /^\.\d+$/) {
|
||||
confess "$0: timeout_system passed a non-positive number first argument.\n";
|
||||
}
|
||||
|
||||
my $proc = Proc::Background->new(@_) or return;
|
||||
my $end_time = $proc->start_time + $timeout;
|
||||
while ($proc->alive and time < $end_time) {
|
||||
sleep(1);
|
||||
}
|
||||
|
||||
my $alive = $proc->alive;
|
||||
if ($alive) {
|
||||
$proc->die;
|
||||
}
|
||||
|
||||
if (wantarray) {
|
||||
return ($proc->wait, $alive);
|
||||
} else {
|
||||
return $proc->wait;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Proc::Background - Generic interface to Unix and Win32 background process management
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Proc::Background;
|
||||
timeout_system($seconds, $command, $arg1);
|
||||
timeout_system($seconds, "$command $arg1");
|
||||
|
||||
my $proc1 = Proc::Background->new($command, $arg1, $arg2);
|
||||
my $proc2 = Proc::Background->new("$command $arg1 1>&2");
|
||||
$proc1->alive;
|
||||
$proc1->die;
|
||||
$proc1->wait;
|
||||
my $time1 = $proc1->start_time;
|
||||
my $time2 = $proc1->end_time;
|
||||
|
||||
# Add an option to kill the process with die when the variable is
|
||||
# DETROYed.
|
||||
my $opts = {'die_upon_destroy' => 1};
|
||||
my $proc3 = Proc::Background->new($opts, $command, $arg1, $arg2);
|
||||
$proc3 = undef;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a generic interface for placing processes in the background on
|
||||
both Unix and Win32 platforms. This module lets you start, kill, wait
|
||||
on, retrieve exit values, and see if background processes still exist.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<new> [options] I<command>, [I<arg>, [I<arg>, ...]]
|
||||
|
||||
=item B<new> [options] 'I<command> [I<arg> [I<arg> ...]]'
|
||||
|
||||
This creates a new background process. As exec() or system() may be
|
||||
passed an array with a single single string element containing a
|
||||
command to be passed to the shell or an array with more than one
|
||||
element to be run without calling the shell, B<new> has the same
|
||||
behavior.
|
||||
|
||||
In certain cases B<new> will attempt to find I<command> on the system
|
||||
and fail if it cannot be found.
|
||||
|
||||
For Win32 operating systems:
|
||||
|
||||
The Win32::Process module is always used to spawn background
|
||||
processes on the Win32 platform. This module always takes a
|
||||
single string argument containing the executable's name and
|
||||
any option arguments. In addition, it requires that the
|
||||
absolute path to the executable is also passed to it. If
|
||||
only a single argument is passed to new, then it is split on
|
||||
whitespace into an array and the first element of the split
|
||||
array is used at the executable's name. If multiple
|
||||
arguments are passed to new, then the first element is used
|
||||
as the executable's name.
|
||||
|
||||
If the executable's name is an absolute path, then new
|
||||
checks to see if the executable exists in the given location
|
||||
or fails otherwise. If the executable's name is not
|
||||
absolute, then the executable is searched for using the PATH
|
||||
environmental variable. The input executable name is always
|
||||
replaced with the absolute path determined by this process.
|
||||
|
||||
In addition, when searching for the executable, the
|
||||
executable is searched for using the unchanged executable
|
||||
name and if that is not found, then it is checked by
|
||||
appending `.exe' to the name in case the name was passed
|
||||
without the `.exe' suffix.
|
||||
|
||||
Finally, the argument array is placed back into a single
|
||||
string and passed to Win32::Process::Create.
|
||||
|
||||
For non-Win32 operating systems, such as Unix:
|
||||
|
||||
If more than one argument is passed to new, then new
|
||||
assumes that the command will not be passed through the
|
||||
shell and the first argument is the executable's relative
|
||||
or absolute path. If the first argument is an absolute
|
||||
path, then it is checked to see if it exists and can be
|
||||
run, otherwise new fails. If the path is not absolute,
|
||||
then the PATH environmental variable is checked to see if
|
||||
the executable can be found. If the executable cannot be
|
||||
found, then new fails. These steps are taking to prevent
|
||||
exec() from failing after an fork() without the caller of
|
||||
new knowing that something failed.
|
||||
|
||||
The first argument to B<new> I<options> may be a reference to a hash
|
||||
which contains key/value pairs to modify Proc::Background's behavior.
|
||||
Currently the only key understood by B<new> is I<die_upon_destroy>.
|
||||
When this value is set to true, then when the Proc::Background object
|
||||
is being DESTROY'ed for any reason (i.e. the variable goes out of
|
||||
scope) the process is killed via the die() method.
|
||||
|
||||
If anything fails, then new returns an empty list in a list context,
|
||||
an undefined value in a scalar context, or nothing in a void context.
|
||||
|
||||
=item B<pid>
|
||||
|
||||
Returns the process ID of the created process. This value is saved
|
||||
even if the process has already finished.
|
||||
|
||||
=item B<alive>
|
||||
|
||||
Return 1 if the process is still active, 0 otherwise.
|
||||
|
||||
=item B<die>
|
||||
|
||||
Reliably try to kill the process. Returns 1 if the process no longer
|
||||
exists once B<die> has completed, 0 otherwise. This will also return
|
||||
1 if the process has already died. On Unix, the following signals are
|
||||
sent to the process in one second intervals until the process dies:
|
||||
HUP, QUIT, INT, KILL.
|
||||
|
||||
=item B<wait>
|
||||
|
||||
Wait for the process to exit. Return the exit status of the command
|
||||
as returned by wait() on the system. To get the actual exit value,
|
||||
divide by 256 or right bit shift by 8, regardless of the operating
|
||||
system being used. If the process never existed, then return an empty
|
||||
list in a list context, an undefined value in a scalar context, or
|
||||
nothing in a void context. This function may be called multiple times
|
||||
even after the process has exited and it will return the same exit
|
||||
status.
|
||||
|
||||
=item B<start_time>
|
||||
|
||||
Return the value that the Perl function time() returned when the
|
||||
process was started.
|
||||
|
||||
=item B<end_time>
|
||||
|
||||
Return the value that the Perl function time() returned when the exit
|
||||
status was obtained from the process.
|
||||
|
||||
=back
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<timeout_system> I<timeout>, I<command>, [I<arg>, [I<arg>...]]
|
||||
|
||||
=item B<timeout_system> 'I<timeout> I<command> [I<arg> [I<arg>...]]'
|
||||
|
||||
Run a command for I<timeout> seconds and if the process did not exit,
|
||||
then kill it. While the timeout is implemented using sleep(), this
|
||||
function makes sure that the full I<timeout> is reached before killing
|
||||
the process. B<timeout_system> does not wait for the complete
|
||||
I<timeout> number of seconds before checking if the process has
|
||||
exited. Rather, it sleeps repeatidly for 1 second and checks to see
|
||||
if the process still exists.
|
||||
|
||||
In a scalar context, B<timeout_system> returns the exit status from
|
||||
the process. In an array context, B<timeout_system> returns a two
|
||||
element array, where the first element is the exist status from the
|
||||
process and the second is set to 1 if the process was killed by
|
||||
B<timeout_system> or 0 if the process exited by itself.
|
||||
|
||||
The exit status is the value returned from the wait() call. If the
|
||||
process was killed, then the return value will include the killing of
|
||||
it. To get the actual exit value, divide by 256.
|
||||
|
||||
If something failed in the creation of the process, the subroutine
|
||||
returns an empty list in a list context, an undefined value in a
|
||||
scalar context, or nothing in a void context.
|
||||
|
||||
=back
|
||||
|
||||
=head1 IMPLEMENTATION
|
||||
|
||||
I<Proc::Background> comes with two modules, I<Proc::Background::Unix>
|
||||
and I<Proc::Background::Win32>. Currently, on Unix platforms
|
||||
I<Proc::Background> uses the I<Proc::Background::Unix> class and on
|
||||
Win32 platforms it uses I<Proc::Background::Win32>, which makes use of
|
||||
I<Win32::Process>.
|
||||
|
||||
The I<Proc::Background> assigns to @ISA either
|
||||
I<Proc::Background::Unix> or I<Proc::Background::Win32>, which does
|
||||
the OS dependent work. The OS independent work is done in
|
||||
I<Proc::Background>.
|
||||
|
||||
Proc::Background uses two variables to keep track of the process.
|
||||
$self->{_os_obj} contains the operating system object to reference the
|
||||
process. On a Unix systems this is the process id (pid). On Win32,
|
||||
it is an object returned from the I<Win32::Process> class. When
|
||||
$self->{_os_obj} exists, then the process is running. When the
|
||||
process dies, this is recorded by deleting $self->{_os_obj} and saving
|
||||
the exit value $self->{_exit_value}.
|
||||
|
||||
Anytime I<alive> is called, a waitpid() is called on the process and
|
||||
the return status, if any, is gathered and saved for a call to
|
||||
I<wait>. This module does not install a signal handler for SIGCHLD.
|
||||
If for some reason, the user has installed a signal handler for
|
||||
SIGCHLD, then, then when this module calls waitpid(), the failure will
|
||||
be noticed and taken as the exited child, but it won't be able to
|
||||
gather the exit status. In this case, the exit status will be set to
|
||||
0.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See also L<Proc::Background::Unix> and L<Proc::Background::Win32>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Blair Zajac <blair@orcaware.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 1998-2005 Blair Zajac. All rights reserved. This
|
||||
package is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,138 @@
|
||||
# Proc::Background::Unix: Unix interface to background process management.
|
||||
#
|
||||
# Copyright (C) 1998-2005 Blair Zajac. All rights reserved.
|
||||
|
||||
package Proc::Background::Unix;
|
||||
|
||||
require 5.004_04;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use Carp;
|
||||
use POSIX qw(:errno_h :sys_wait_h);
|
||||
|
||||
use vars qw(@ISA $VERSION);
|
||||
@ISA = qw(Exporter);
|
||||
$VERSION = sprintf '%d.%02d', '$Revision: 1.10 $' =~ /(\d+)\.(\d+)/;
|
||||
|
||||
# Start the background process. If it is started sucessfully, then record
|
||||
# the process id in $self->{_os_obj}.
|
||||
sub _new {
|
||||
my $class = shift;
|
||||
|
||||
unless (@_ > 0) {
|
||||
confess "Proc::Background::Unix::_new called with insufficient number of arguments";
|
||||
}
|
||||
|
||||
return unless defined $_[0];
|
||||
|
||||
# If there is only one element in the @_ array, then it may be a
|
||||
# command to be passed to the shell and should not be checked, in
|
||||
# case the command sets environmental variables in the beginning,
|
||||
# i.e. 'VAR=arg ls -l'. If there is more than one element in the
|
||||
# array, then check that the first element is a valid executable
|
||||
# that can be found through the PATH and find the absolute path to
|
||||
# the executable. If the executable is found, then replace the
|
||||
# first element it with the absolute path.
|
||||
my @args = @_;
|
||||
if (@_ > 1) {
|
||||
$args[0] = Proc::Background::_resolve_path($args[0]) or return;
|
||||
}
|
||||
|
||||
my $self = bless {}, $class;
|
||||
|
||||
# Fork a child process.
|
||||
my $pid;
|
||||
{
|
||||
if ($pid = fork()) {
|
||||
# parent
|
||||
$self->{_os_obj} = $pid;
|
||||
$self->{_pid} = $pid;
|
||||
last;
|
||||
} elsif (defined $pid) {
|
||||
# child
|
||||
exec @_ or croak "$0: exec failed: $!\n";
|
||||
} elsif ($! == EAGAIN) {
|
||||
sleep 5;
|
||||
redo;
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
# Wait for the child.
|
||||
sub _waitpid {
|
||||
my $self = shift;
|
||||
my $timeout = shift;
|
||||
|
||||
{
|
||||
# Try to wait on the process.
|
||||
my $result = waitpid($self->{_os_obj}, $timeout ? 0 : WNOHANG);
|
||||
# Process finished. Grab the exit value.
|
||||
if ($result == $self->{_os_obj}) {
|
||||
return (0, $?);
|
||||
}
|
||||
# Process already reaped. We don't know the exist status.
|
||||
elsif ($result == -1 and $! == ECHILD) {
|
||||
return (1, 0);
|
||||
}
|
||||
# Process still running.
|
||||
elsif ($result == 0) {
|
||||
return (2, 0);
|
||||
}
|
||||
# If we reach here, then waitpid caught a signal, so let's retry it.
|
||||
redo;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _die {
|
||||
my $self = shift;
|
||||
|
||||
# Try to kill the process with different signals. Calling alive() will
|
||||
# collect the exit status of the program.
|
||||
SIGNAL: {
|
||||
foreach my $signal (qw(HUP QUIT INT KILL)) {
|
||||
my $count = 5;
|
||||
while ($count and $self->alive) {
|
||||
--$count;
|
||||
kill($signal, $self->{_os_obj});
|
||||
last SIGNAL unless $self->alive;
|
||||
sleep 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Proc::Background::Unix - Unix interface to process mangement
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Do not use this module directly.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a process management class designed specifically for Unix
|
||||
operating systems. It is not meant used except through the
|
||||
I<Proc::Background> class. See L<Proc::Background> for more information.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Blair Zajac <blair@orcaware.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 1998-2005 Blair Zajac. All rights reserved. This
|
||||
package is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,157 @@
|
||||
# Proc::Background::Win32 Windows interface to background process management.
|
||||
#
|
||||
# Copyright (C) 1998-2005 Blair Zajac. All rights reserved.
|
||||
|
||||
package Proc::Background::Win32;
|
||||
|
||||
require 5.004_04;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use Carp;
|
||||
|
||||
use vars qw(@ISA $VERSION);
|
||||
@ISA = qw(Exporter);
|
||||
$VERSION = sprintf '%d.%02d', '$Revision: 1.10 $' =~ /(\d+)\.(\d+)/;
|
||||
|
||||
BEGIN {
|
||||
eval "use Win32";
|
||||
$@ and die "Proc::Background::Win32 needs Win32 from libwin32-?.??.zip to run.\n";
|
||||
eval "use Win32::Process";
|
||||
$@ and die "Proc::Background::Win32 needs Win32::Process from libwin32-?.??.zip to run.\n";
|
||||
}
|
||||
|
||||
sub _new {
|
||||
my $class = shift;
|
||||
|
||||
unless (@_ > 0) {
|
||||
confess "Proc::Background::Win32::_new called with insufficient number of arguments";
|
||||
}
|
||||
|
||||
return unless defined $_[0];
|
||||
|
||||
# If there is only one element in the @_ array, then just split the
|
||||
# argument by whitespace. If there is more than one element in @_,
|
||||
# then assume that each argument should be properly protected from
|
||||
# the shell so that whitespace and special characters are passed
|
||||
# properly to the program, just as it would be in a Unix
|
||||
# environment. This will ensure that a single argument with
|
||||
# whitespace will not be split into multiple arguments by the time
|
||||
# the program is run. Make sure that any arguments that are already
|
||||
# protected stay protected. Then convert unquoted "'s into \"'s.
|
||||
# Finally, check for whitespace and protect it.
|
||||
my @args;
|
||||
if (@_ == 1) {
|
||||
@args = split(' ', $_[0]);
|
||||
} else {
|
||||
@args = @_;
|
||||
for (my $i=1; $i<@args; ++$i) {
|
||||
my $arg = $args[$i];
|
||||
$arg =~ s#\\\\#\200#g;
|
||||
$arg =~ s#\\"#\201#g;
|
||||
$arg =~ s#"#\\"#g;
|
||||
$arg =~ s#\200#\\\\#g;
|
||||
$arg =~ s#\201#\\"#g;
|
||||
if (length($arg) == 0 or $arg =~ /\s/) {
|
||||
$arg = "\"$arg\"";
|
||||
}
|
||||
$args[$i] = $arg;
|
||||
}
|
||||
}
|
||||
|
||||
# Find the absolute path to the program. If it cannot be found,
|
||||
# then return. To work around a problem where
|
||||
# Win32::Process::Create cannot start a process when the full
|
||||
# pathname has a space in it, convert the full pathname to the
|
||||
# Windows short 8.3 format which contains no spaces.
|
||||
$args[0] = Proc::Background::_resolve_path($args[0]) or return;
|
||||
$args[0] = Win32::GetShortPathName($args[0]);
|
||||
|
||||
my $self = bless {}, $class;
|
||||
|
||||
# Perl 5.004_04 cannot run Win32::Process::Create on a nonexistant
|
||||
# hash key.
|
||||
my $os_obj = 0;
|
||||
|
||||
# Create the process.
|
||||
if (Win32::Process::Create($os_obj,
|
||||
$args[0],
|
||||
"@args",
|
||||
0,
|
||||
NORMAL_PRIORITY_CLASS,
|
||||
'.')) {
|
||||
$self->{_pid} = $os_obj->GetProcessID;
|
||||
$self->{_os_obj} = $os_obj;
|
||||
return $self;
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Reap the child.
|
||||
sub _waitpid {
|
||||
my ($self, $timeout) = @_;
|
||||
|
||||
# Try to wait on the process.
|
||||
my $result = $self->{_os_obj}->Wait($timeout ? INFINITE : 0);
|
||||
# Process finished. Grab the exit value.
|
||||
if ($result == 1) {
|
||||
my $_exit_status;
|
||||
$self->{_os_obj}->GetExitCode($_exit_status);
|
||||
return (0, $_exit_status<<8);
|
||||
}
|
||||
# Process still running.
|
||||
elsif ($result == 0) {
|
||||
return (2, 0);
|
||||
}
|
||||
# If we reach here, then something odd happened.
|
||||
return (0, 1<<8);
|
||||
}
|
||||
|
||||
sub _die {
|
||||
my $self = shift;
|
||||
|
||||
# Try the kill the process several times. Calling alive() will
|
||||
# collect the exit status of the program.
|
||||
my $count = 5;
|
||||
while ($count and $self->alive) {
|
||||
--$count;
|
||||
$self->{_os_obj}->Kill(1<<8);
|
||||
last unless $self->alive;
|
||||
sleep 1;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Proc::Background::Win32 - Interface to process mangement on Win32 systems
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Do not use this module directly.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a process management class designed specifically for Win32
|
||||
operating systems. It is not meant used except through the
|
||||
I<Proc::Background> class. See L<Proc::Background> for more information.
|
||||
|
||||
=head1 IMPLEMENTATION
|
||||
|
||||
This package uses the Win32::Process class to manage the objects.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Blair Zajac <blair@orcaware.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 1998-2005 Blair Zajac. All rights reserved. This
|
||||
package is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,304 @@
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Program;
|
||||
my $m_program = new Program('ls');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Program is a generic program wrapper that allows easy use of programs on
|
||||
multipul platforms with the correct file handle redirection.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
package Program;
|
||||
|
||||
###################
|
||||
# Standard Modules
|
||||
use strict;
|
||||
use Config;
|
||||
use FileHandle;
|
||||
|
||||
###################
|
||||
# Variables
|
||||
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
|
||||
@ISA = qw();
|
||||
@EXPORT = qw();
|
||||
@EXPORT_OK = qw();
|
||||
$VERSION = 0.04;
|
||||
|
||||
# This hash contains the values for redirection.
|
||||
my %m_redirect_values;
|
||||
|
||||
# Standard values
|
||||
$m_redirect_values{'none'} = '';
|
||||
$m_redirect_values{'stdout&stderr2stdout'} = '2>&1';
|
||||
$m_redirect_values{'stdout&stderr2stderr'} = '1>&2';
|
||||
$m_redirect_values{'stdout2stderr&stderr2stdout'} = '3>&1 1>&2 2>&3 3>&-';
|
||||
|
||||
# Platform specific values
|
||||
if ($Config{'osname'} eq 'MSWin32')
|
||||
{
|
||||
if ($Config{'osvers'} ge 4.0)
|
||||
{
|
||||
$m_redirect_values{'stdout2stdnull'} = '1>NUL';
|
||||
$m_redirect_values{'stderr2stdnull'} = '2>NUL';
|
||||
}
|
||||
else
|
||||
{
|
||||
$m_redirect_values{'stdout2stdnull'} = '1>';
|
||||
$m_redirect_values{'stderr2stdnull'} = '2>';
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$m_redirect_values{'stdout2stdnull'} = '1>/dev/null';
|
||||
$m_redirect_values{'stderr2stdnull'} = '2>/dev/null';
|
||||
}
|
||||
|
||||
###################
|
||||
# Functions
|
||||
|
||||
################################################################################
|
||||
# Function: new()
|
||||
|
||||
=head2 B<new()>
|
||||
|
||||
Description: This method returns an objective interface the the passed program.
|
||||
Arguments: $program
|
||||
Return: class
|
||||
Usage: my $ls = new Program('ls');
|
||||
|
||||
=cut
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $program = shift;
|
||||
|
||||
my $self = bless {}, $class;
|
||||
$self->{'PROGRAM'} = $program;
|
||||
$self->{'CHOMP'} = 1;
|
||||
$self->{'REDIRECT'} = 'stdout&stderr2stdout';
|
||||
$self->{'LAST_COMMAND'} = "No commands have been executed yet.";
|
||||
$self->{'EXIT_STATUS'} = 0;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# Function: strip_new_lines()
|
||||
|
||||
=head2 B<strip_new_lines()>
|
||||
|
||||
Description: This functions is used to set wether the output from a command
|
||||
has trailing new lines removed.
|
||||
Arguments: 0 to turn chomping off
|
||||
1 to turn chomping on
|
||||
Default: 1
|
||||
Return: true if chomping is on else undef
|
||||
Usage: $ls->strip_new_lines(1);
|
||||
$ls->strip_new_lines(0);
|
||||
|
||||
=cut
|
||||
|
||||
sub strip_new_lines
|
||||
{
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
|
||||
if (scalar $value)
|
||||
{
|
||||
$self->{'CHOMP'} = $value;
|
||||
}
|
||||
else
|
||||
{
|
||||
return $self->{'CHOMP'};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
################################################################################
|
||||
# Function: redirect()
|
||||
|
||||
=head2 B<redirect()>
|
||||
|
||||
Description: This functions is used to set the STDOUT and STDERR redirection
|
||||
for commands executed by the program.
|
||||
Arguments: possible values are stdout&stderr2stdout, stdout&stderr2stderr
|
||||
stdout2stderr&stderr2stdout, stdout2stdnull, stderr2stdnull
|
||||
Default: sdtout&stderr2stdout
|
||||
Return: redirection option if nothing passed else set the redirection
|
||||
Usage: $ls->redirect('stderr2sdtnull');
|
||||
|
||||
=cut
|
||||
|
||||
sub redirect
|
||||
{
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
|
||||
if (scalar $value)
|
||||
{
|
||||
$self->{'REDIRECT'} = $value;
|
||||
}
|
||||
else
|
||||
{
|
||||
return $m_redirect_values{$self->{'REDIRECT'}};
|
||||
}
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# Function: last_command()
|
||||
|
||||
=head2 B<last_command()>
|
||||
|
||||
Description: This function returns the last command executed.
|
||||
Arguments: None.
|
||||
Return: The last command
|
||||
Usage: print $ls->last_command();
|
||||
|
||||
=cut
|
||||
|
||||
sub last_command
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{'LAST_COMMAND'};
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# Function: output()
|
||||
|
||||
=head2 B<output()>
|
||||
|
||||
Description: This function returns the output from a program.
|
||||
Arguments: command to execute.
|
||||
Return: array if called in an array context else string
|
||||
Usage: my $output = $ls->output("-l");
|
||||
my @output = $ls->output("-l");
|
||||
|
||||
=cut
|
||||
|
||||
sub output
|
||||
{
|
||||
my $self = shift;
|
||||
my $command = shift;
|
||||
my $exec_command = "$self->{'PROGRAM'} $command " . $self->redirect();
|
||||
$self->{'LAST_COMMAND'} = $exec_command;
|
||||
|
||||
my @output_list;
|
||||
my $output_line;
|
||||
if (wantarray)
|
||||
{
|
||||
@output_list = `$exec_command`;
|
||||
foreach my $line (@output_list)
|
||||
{
|
||||
chomp $line if $self->strip_new_lines();
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$output_line = `$exec_command`;
|
||||
chomp $output_line if $self->strip_new_lines();
|
||||
}
|
||||
$self->{'EXIT_STATUS'} = $?/256;
|
||||
|
||||
return wantarray ? @output_list : $output_line;
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# Function: status()
|
||||
|
||||
=head2 B<status()>
|
||||
|
||||
Description: This function returns the exit status of the last
|
||||
command.
|
||||
Arguments: None.
|
||||
Return: exit status.
|
||||
Usage: my $status = $ls->status();
|
||||
|
||||
=cut
|
||||
|
||||
sub status
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{'EXIT_STATUS'};
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# Function: success()
|
||||
|
||||
=head2 B<success()>
|
||||
|
||||
Description: This function returns true if the last command was successful
|
||||
Arguments: None.
|
||||
Return: true for success else undef.
|
||||
Usage: if ($ls->success())
|
||||
{
|
||||
Print "Success\n";
|
||||
}
|
||||
else
|
||||
{
|
||||
Print "Failure\n";
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub success
|
||||
{
|
||||
my $self = shift;
|
||||
return 1 if $self->status() eq 0;
|
||||
return undef
|
||||
}
|
||||
|
||||
################################################################################
|
||||
# Function: open()
|
||||
|
||||
=head2 B<open()>
|
||||
|
||||
Description: This function returns an open file handle for the passed command
|
||||
NOTE: Since the exit status of the file handle cannot be
|
||||
retrieved by this module the user must check the exit status of
|
||||
the file handle using the $fh->error() method. See IO::Handle.
|
||||
Arguments: command to execute.
|
||||
Return: open file handle.
|
||||
Usage: my $fh = $ls->open("-l)
|
||||
while (<$fh>)
|
||||
{
|
||||
print "$_\n";
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub open
|
||||
{
|
||||
my $self = shift;
|
||||
my $command = shift;
|
||||
|
||||
my $exec_command = "$self->{'PROGRAM'} $command " . $self->redirect() ." |";
|
||||
$self->{'LAST_COMMAND'} = $exec_command;
|
||||
$self->{'EXIT_STATUS'} = 0;
|
||||
|
||||
my $fh = new FileHandle($exec_command);
|
||||
return $fh;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
FileHandle
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Bernard Davison bernard@gondwana.com.au
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 2000, Gondwanatech.
|
||||
|
||||
=cut
|
||||
|
||||
Executable
+583
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,379 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK);
|
||||
|
||||
$VERSION = '0.99';
|
||||
|
||||
use Exporter ();
|
||||
@ISA = ('Exporter');
|
||||
|
||||
@EXPORT_OK = qw(Namespaces Validation);
|
||||
|
||||
use File::Basename qw(dirname);
|
||||
use File::Spec ();
|
||||
use Symbol qw(gensym);
|
||||
use XML::SAX::ParserFactory (); # loaded for simplicity
|
||||
|
||||
use constant PARSER_DETAILS => "ParserDetails.ini";
|
||||
|
||||
use constant Namespaces => "http://xml.org/sax/features/namespaces";
|
||||
use constant Validation => "http://xml.org/sax/features/validation";
|
||||
|
||||
my $known_parsers = undef;
|
||||
|
||||
# load_parsers takes the ParserDetails.ini file out of the same directory
|
||||
# that XML::SAX is in, and looks at it. Format in POD below
|
||||
|
||||
=begin EXAMPLE
|
||||
|
||||
[XML::SAX::PurePerl]
|
||||
http://xml.org/sax/features/namespaces = 1
|
||||
http://xml.org/sax/features/validation = 0
|
||||
# a comment
|
||||
|
||||
# blank lines ignored
|
||||
|
||||
[XML::SAX::AnotherParser]
|
||||
http://xml.org/sax/features/namespaces = 0
|
||||
http://xml.org/sax/features/validation = 1
|
||||
|
||||
=end EXAMPLE
|
||||
|
||||
=cut
|
||||
|
||||
sub load_parsers {
|
||||
my $class = shift;
|
||||
my $dir = shift;
|
||||
|
||||
# reset parsers
|
||||
$known_parsers = [];
|
||||
|
||||
# get directory from wherever XML::SAX is installed
|
||||
if (!$dir) {
|
||||
$dir = $INC{'XML/SAX.pm'};
|
||||
$dir = dirname($dir);
|
||||
}
|
||||
|
||||
my $fh = gensym();
|
||||
if (!open($fh, File::Spec->catfile($dir, "SAX", PARSER_DETAILS))) {
|
||||
XML::SAX->do_warn("could not find " . PARSER_DETAILS . " in $dir/SAX\n");
|
||||
return $class;
|
||||
}
|
||||
|
||||
$known_parsers = $class->_parse_ini_file($fh);
|
||||
|
||||
return $class;
|
||||
}
|
||||
|
||||
sub _parse_ini_file {
|
||||
my $class = shift;
|
||||
my ($fh) = @_;
|
||||
|
||||
my @config;
|
||||
|
||||
my $lineno = 0;
|
||||
while (defined(my $line = <$fh>)) {
|
||||
$lineno++;
|
||||
my $original = $line;
|
||||
# strip whitespace
|
||||
$line =~ s/\s*$//m;
|
||||
$line =~ s/^\s*//m;
|
||||
# strip comments
|
||||
$line =~ s/[#;].*$//m;
|
||||
# ignore blanks
|
||||
next if $line =~ /^$/m;
|
||||
|
||||
# heading
|
||||
if ($line =~ /^\[\s*(.*)\s*\]$/m) {
|
||||
push @config, { Name => $1 };
|
||||
next;
|
||||
}
|
||||
|
||||
# instruction
|
||||
elsif ($line =~ /^(.*?)\s*?=\s*(.*)$/) {
|
||||
unless(@config) {
|
||||
push @config, { Name => '' };
|
||||
}
|
||||
$config[-1]{Features}{$1} = $2;
|
||||
}
|
||||
|
||||
# not whitespace, comment, or instruction
|
||||
else {
|
||||
die "Invalid line in ini: $lineno\n>>> $original\n";
|
||||
}
|
||||
}
|
||||
|
||||
return \@config;
|
||||
}
|
||||
|
||||
sub parsers {
|
||||
my $class = shift;
|
||||
if (!$known_parsers) {
|
||||
$class->load_parsers();
|
||||
}
|
||||
return $known_parsers;
|
||||
}
|
||||
|
||||
sub remove_parser {
|
||||
my $class = shift;
|
||||
my ($parser_module) = @_;
|
||||
|
||||
if (!$known_parsers) {
|
||||
$class->load_parsers();
|
||||
}
|
||||
|
||||
@$known_parsers = grep { $_->{Name} ne $parser_module } @$known_parsers;
|
||||
|
||||
return $class;
|
||||
}
|
||||
|
||||
sub add_parser {
|
||||
my $class = shift;
|
||||
my ($parser_module) = @_;
|
||||
|
||||
if (!$known_parsers) {
|
||||
$class->load_parsers();
|
||||
}
|
||||
|
||||
# first load module, then query features, then push onto known_parsers,
|
||||
|
||||
my $parser_file = $parser_module;
|
||||
$parser_file =~ s/::/\//g;
|
||||
$parser_file .= ".pm";
|
||||
|
||||
require $parser_file;
|
||||
|
||||
my @features = $parser_module->supported_features();
|
||||
|
||||
my $new = { Name => $parser_module };
|
||||
foreach my $feature (@features) {
|
||||
$new->{Features}{$feature} = 1;
|
||||
}
|
||||
|
||||
# If exists in list already, move to end.
|
||||
my $done = 0;
|
||||
my $pos = undef;
|
||||
for (my $i = 0; $i < @$known_parsers; $i++) {
|
||||
my $p = $known_parsers->[$i];
|
||||
if ($p->{Name} eq $parser_module) {
|
||||
$pos = $i;
|
||||
}
|
||||
}
|
||||
if (defined $pos) {
|
||||
splice(@$known_parsers, $pos, 1);
|
||||
push @$known_parsers, $new;
|
||||
$done++;
|
||||
}
|
||||
|
||||
# Otherwise (not in list), add at end of list.
|
||||
if (!$done) {
|
||||
push @$known_parsers, $new;
|
||||
}
|
||||
|
||||
return $class;
|
||||
}
|
||||
|
||||
sub save_parsers {
|
||||
my $class = shift;
|
||||
|
||||
# get directory from wherever XML::SAX is installed
|
||||
my $dir = $INC{'XML/SAX.pm'};
|
||||
$dir = dirname($dir);
|
||||
|
||||
my $file = File::Spec->catfile($dir, "SAX", PARSER_DETAILS);
|
||||
chmod 0644, $file;
|
||||
unlink($file);
|
||||
|
||||
my $fh = gensym();
|
||||
open($fh, ">$file") ||
|
||||
die "Cannot write to $file: $!";
|
||||
|
||||
foreach my $p (@$known_parsers) {
|
||||
print $fh "[$p->{Name}]\n";
|
||||
foreach my $key (keys %{$p->{Features}}) {
|
||||
print $fh "$key = $p->{Features}{$key}\n";
|
||||
}
|
||||
print $fh "\n";
|
||||
}
|
||||
|
||||
print $fh "\n";
|
||||
|
||||
close $fh;
|
||||
|
||||
return $class;
|
||||
}
|
||||
|
||||
sub do_warn {
|
||||
my $class = shift;
|
||||
# Don't output warnings if running under Test::Harness
|
||||
warn(@_) unless $ENV{HARNESS_ACTIVE};
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::SAX - Simple API for XML
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use XML::SAX;
|
||||
|
||||
# get a list of known parsers
|
||||
my $parsers = XML::SAX->parsers();
|
||||
|
||||
# add/update a parser
|
||||
XML::SAX->add_parser(q(XML::SAX::PurePerl));
|
||||
|
||||
# remove parser
|
||||
XML::SAX->remove_parser(q(XML::SAX::Foodelberry));
|
||||
|
||||
# save parsers
|
||||
XML::SAX->save_parsers();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
XML::SAX is a SAX parser access API for Perl. It includes classes
|
||||
and APIs required for implementing SAX drivers, along with a factory
|
||||
class for returning any SAX parser installed on the user's system.
|
||||
|
||||
=head1 USING A SAX2 PARSER
|
||||
|
||||
The factory class is XML::SAX::ParserFactory. Please see the
|
||||
documentation of that module for how to instantiate a SAX parser:
|
||||
L<XML::SAX::ParserFactory>. However if you don't want to load up
|
||||
another manual page, here's a short synopsis:
|
||||
|
||||
use XML::SAX::ParserFactory;
|
||||
use XML::SAX::XYZHandler;
|
||||
my $handler = XML::SAX::XYZHandler->new();
|
||||
my $p = XML::SAX::ParserFactory->parser(Handler => $handler);
|
||||
$p->parse_uri("foo.xml");
|
||||
# or $p->parse_string("<foo/>") or $p->parse_file($fh);
|
||||
|
||||
This will automatically load a SAX2 parser (defaulting to
|
||||
XML::SAX::PurePerl if no others are found) and return it to you.
|
||||
|
||||
In order to learn how to use SAX to parse XML, you will need to read
|
||||
L<XML::SAX::Intro> and for reference, L<XML::SAX::Specification>.
|
||||
|
||||
=head1 WRITING A SAX2 PARSER
|
||||
|
||||
The first thing to remember in writing a SAX2 parser is to subclass
|
||||
XML::SAX::Base. This will make your life infinitely easier, by providing
|
||||
a number of methods automagically for you. See L<XML::SAX::Base> for more
|
||||
details.
|
||||
|
||||
When writing a SAX2 parser that is compatible with XML::SAX, you need
|
||||
to inform XML::SAX of the presence of that driver when you install it.
|
||||
In order to do that, XML::SAX contains methods for saving the fact that
|
||||
the parser exists on your system to a "INI" file, which is then loaded
|
||||
to determine which parsers are installed.
|
||||
|
||||
The best way to do this is to follow these rules:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Add XML::SAX as a prerequisite in Makefile.PL:
|
||||
|
||||
WriteMakefile(
|
||||
...
|
||||
PREREQ_PM => { 'XML::SAX' => 0 },
|
||||
...
|
||||
);
|
||||
|
||||
Alternatively you may wish to check for it in other ways that will
|
||||
cause more than just a warning.
|
||||
|
||||
=item * Add the following code snippet to your Makefile.PL:
|
||||
|
||||
sub MY::install {
|
||||
package MY;
|
||||
my $script = shift->SUPER::install(@_);
|
||||
if (ExtUtils::MakeMaker::prompt(
|
||||
"Do you want to modify ParserDetails.ini?", 'Y')
|
||||
=~ /^y/i) {
|
||||
$script =~ s/install :: (.*)$/install :: $1 install_sax_driver/m;
|
||||
$script .= <<"INSTALL";
|
||||
|
||||
install_sax_driver :
|
||||
\t\@\$(PERL) -MXML::SAX -e "XML::SAX->add_parser(q(\$(NAME)))->save_parsers()"
|
||||
|
||||
INSTALL
|
||||
}
|
||||
return $script;
|
||||
}
|
||||
|
||||
Note that you should check the output of this - \$(NAME) will use the name of
|
||||
your distribution, which may not be exactly what you want. For example XML::LibXML
|
||||
has a driver called XML::LibXML::SAX::Generator, which is used in place of
|
||||
\$(NAME) in the above.
|
||||
|
||||
=item * Add an XML::SAX test:
|
||||
|
||||
A test file should be added to your t/ directory containing something like the
|
||||
following:
|
||||
|
||||
use Test;
|
||||
BEGIN { plan tests => 3 }
|
||||
use XML::SAX;
|
||||
use XML::SAX::PurePerl::DebugHandler;
|
||||
XML::SAX->add_parser(q(XML::SAX::MyDriver));
|
||||
local $XML::SAX::ParserPackage = 'XML::SAX::MyDriver';
|
||||
eval {
|
||||
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||
ok($handler);
|
||||
my $parser = XML::SAX::ParserFactory->parser(Handler => $handler);
|
||||
ok($parser);
|
||||
ok($parser->isa('XML::SAX::MyDriver');
|
||||
$parser->parse_string("<tag/>");
|
||||
ok($handler->{seen}{start_element});
|
||||
};
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
By default, XML::SAX exports nothing into the caller's namespace. However you
|
||||
can request the symbols C<Namespaces> and C<Validation> which are the
|
||||
URIs for those features, allowing an easier way to request those features
|
||||
via ParserFactory:
|
||||
|
||||
use XML::SAX qw(Namespaces Validation);
|
||||
my $factory = XML::SAX::ParserFactory->new();
|
||||
$factory->require_feature(Namespaces);
|
||||
$factory->require_feature(Validation);
|
||||
my $parser = $factory->parser();
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Current maintainer: Grant McLean, grantm@cpan.org
|
||||
|
||||
Originally written by:
|
||||
|
||||
Matt Sergeant, matt@sergeant.org
|
||||
|
||||
Kip Hampton, khampton@totalcinema.com
|
||||
|
||||
Robin Berjon, robin@knowscape.com
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This is free software, you may use it and distribute it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<XML::SAX::Base> for writing SAX Filters and Parsers
|
||||
|
||||
L<XML::SAX::PurePerl> for an XML parser written in 100%
|
||||
pure perl.
|
||||
|
||||
L<XML::SAX::Exception> for details on exception handling
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,134 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::DocumentLocator;
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %object;
|
||||
tie %object, $class, @_;
|
||||
|
||||
return bless \%object, $class;
|
||||
}
|
||||
|
||||
sub TIEHASH {
|
||||
my $class = shift;
|
||||
my ($pubmeth, $sysmeth, $linemeth, $colmeth, $encmeth, $xmlvmeth) = @_;
|
||||
return bless {
|
||||
pubmeth => $pubmeth,
|
||||
sysmeth => $sysmeth,
|
||||
linemeth => $linemeth,
|
||||
colmeth => $colmeth,
|
||||
encmeth => $encmeth,
|
||||
xmlvmeth => $xmlvmeth,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $key) = @_;
|
||||
my $method;
|
||||
if ($key eq 'PublicId') {
|
||||
$method = $self->{pubmeth};
|
||||
}
|
||||
elsif ($key eq 'SystemId') {
|
||||
$method = $self->{sysmeth};
|
||||
}
|
||||
elsif ($key eq 'LineNumber') {
|
||||
$method = $self->{linemeth};
|
||||
}
|
||||
elsif ($key eq 'ColumnNumber') {
|
||||
$method = $self->{colmeth};
|
||||
}
|
||||
elsif ($key eq 'Encoding') {
|
||||
$method = $self->{encmeth};
|
||||
}
|
||||
elsif ($key eq 'XMLVersion') {
|
||||
$method = $self->{xmlvmeth};
|
||||
}
|
||||
if ($method) {
|
||||
my $value = $method->($key);
|
||||
return $value;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $key) = @_;
|
||||
if ($key =~ /^(PublicId|SystemId|LineNumber|ColumnNumber|Encoding|XMLVersion)$/) {
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
my ($self, $key, $value) = @_;
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my ($self) = @_;
|
||||
}
|
||||
|
||||
sub FIRSTKEY {
|
||||
my ($self) = @_;
|
||||
# assignment resets.
|
||||
$self->{keys} = {
|
||||
PublicId => 1,
|
||||
SystemId => 1,
|
||||
LineNumber => 1,
|
||||
ColumnNumber => 1,
|
||||
Encoding => 1,
|
||||
XMLVersion => 1,
|
||||
};
|
||||
return each %{$self->{keys}};
|
||||
}
|
||||
|
||||
sub NEXTKEY {
|
||||
my ($self, $lastkey) = @_;
|
||||
return each %{$self->{keys}};
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::SAX::DocumentLocator - Helper class for document locators
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $locator = XML::SAX::DocumentLocator->new(
|
||||
sub { $object->get_public_id },
|
||||
sub { $object->get_system_id },
|
||||
sub { $reader->current_line },
|
||||
sub { $reader->current_column },
|
||||
sub { $reader->get_encoding },
|
||||
sub { $reader->get_xml_version },
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module gives you a tied hash reference that calls the
|
||||
specified closures when asked for PublicId, SystemId,
|
||||
LineNumber and ColumnNumber.
|
||||
|
||||
It is useful for writing SAX Parsers so that you don't have
|
||||
to constantly update the line numbers in a hash reference on
|
||||
the object you pass to set_document_locator(). See the source
|
||||
code for XML::SAX::PurePerl for a usage example.
|
||||
|
||||
=head1 API
|
||||
|
||||
There is only 1 method: C<new>. Simply pass it a list of
|
||||
closures that when called will return the PublicId, the
|
||||
SystemId, the LineNumber, the ColumnNumber, the Encoding
|
||||
and the XMLVersion respectively.
|
||||
|
||||
The closures are passed a single parameter, the key being
|
||||
requested. But you're free to ignore that.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,129 @@
|
||||
package XML::SAX::Exception;
|
||||
BEGIN {
|
||||
$XML::SAX::Exception::VERSION = '1.08';
|
||||
}
|
||||
|
||||
use strict;
|
||||
|
||||
use overload '""' => "stringify",
|
||||
'fallback' => 1;
|
||||
|
||||
use vars qw($StackTrace);
|
||||
|
||||
use Carp;
|
||||
|
||||
$StackTrace = $ENV{XML_DEBUG} || 0;
|
||||
|
||||
# Other exception classes:
|
||||
|
||||
@XML::SAX::Exception::NotRecognized::ISA = ('XML::SAX::Exception');
|
||||
@XML::SAX::Exception::NotSupported::ISA = ('XML::SAX::Exception');
|
||||
@XML::SAX::Exception::Parse::ISA = ('XML::SAX::Exception');
|
||||
|
||||
|
||||
sub throw {
|
||||
my $class = shift;
|
||||
if (ref($class)) {
|
||||
die $class;
|
||||
}
|
||||
die $class->new(@_);
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %opts = @_;
|
||||
confess "Invalid options: " . join(', ', keys %opts) unless exists $opts{Message};
|
||||
|
||||
bless { ($StackTrace ? (StackTrace => stacktrace()) : ()), %opts },
|
||||
$class;
|
||||
}
|
||||
|
||||
sub stringify {
|
||||
my $self = shift;
|
||||
local $^W;
|
||||
my $error;
|
||||
if (exists $self->{LineNumber}) {
|
||||
$error = $self->{Message} . " [Ln: " . $self->{LineNumber} .
|
||||
", Col: " . $self->{ColumnNumber} . "]";
|
||||
}
|
||||
else {
|
||||
$error = $self->{Message};
|
||||
}
|
||||
if ($StackTrace) {
|
||||
$error .= stackstring($self->{StackTrace});
|
||||
}
|
||||
$error .= "\n";
|
||||
return $error;
|
||||
}
|
||||
|
||||
sub stacktrace {
|
||||
my $i = 2;
|
||||
my @fulltrace;
|
||||
while (my @trace = caller($i++)) {
|
||||
my %hash;
|
||||
@hash{qw(Package Filename Line)} = @trace[0..2];
|
||||
push @fulltrace, \%hash;
|
||||
}
|
||||
return \@fulltrace;
|
||||
}
|
||||
|
||||
sub stackstring {
|
||||
my $stacktrace = shift;
|
||||
my $string = "\nFrom:\n";
|
||||
foreach my $current (@$stacktrace) {
|
||||
$string .= $current->{Filename} . " Line: " . $current->{Line} . "\n";
|
||||
}
|
||||
return $string;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::SAX::Exception - Exception classes for XML::SAX
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
throw XML::SAX::Exception::NotSupported(
|
||||
Message => "The foo feature is not supported",
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is the base class for all SAX Exceptions, those defined in
|
||||
the spec as well as those that one may create for one's own SAX errors.
|
||||
|
||||
There are three subclasses included, corresponding to those of the SAX
|
||||
spec:
|
||||
|
||||
XML::SAX::Exception::NotSupported
|
||||
XML::SAX::Exception::NotRecognized
|
||||
XML::SAX::Exception::Parse
|
||||
|
||||
Use them wherever you want, and as much as possible when you encounter
|
||||
such errors. SAX is meant to use exceptions as much as possible to
|
||||
flag problems.
|
||||
|
||||
=head1 CREATING NEW EXCEPTION CLASSES
|
||||
|
||||
All you need to do to create a new exception class is:
|
||||
|
||||
@XML::SAX::Exception::MyException::ISA = ('XML::SAX::Exception')
|
||||
|
||||
The given package doesn't need to exist, it'll behave correctly this
|
||||
way. If your exception refines an existing exception class, then you
|
||||
may also inherit from that instead of from the base class.
|
||||
|
||||
=head1 THROWING EXCEPTIONS
|
||||
|
||||
This is as simple as exemplified in the SYNOPSIS. In fact, there's
|
||||
nothing more to know. All you have to do is:
|
||||
|
||||
throw XML::SAX::Exception::MyException( Message => 'Something went wrong' );
|
||||
|
||||
and voila, you've thrown an exception which can be caught in an eval block.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,407 @@
|
||||
=head1 NAME
|
||||
|
||||
XML::SAX::Intro - An Introduction to SAX Parsing with Perl
|
||||
|
||||
=head1 Introduction
|
||||
|
||||
XML::SAX is a new way to work with XML Parsers in Perl. In this article
|
||||
we'll discuss why you should be using SAX, why you should be using
|
||||
XML::SAX, and we'll see some of the finer implementation details. The
|
||||
text below assumes some familiarity with callback, or push based
|
||||
parsing, but if you are unfamiliar with these techniques then a good
|
||||
place to start is Kip Hampton's excellent series of articles on XML.com.
|
||||
|
||||
=head1 Replacing XML::Parser
|
||||
|
||||
The de-facto way of parsing XML under perl is to use Larry Wall and
|
||||
Clark Cooper's XML::Parser. This module is a Perl and XS wrapper around
|
||||
the expat XML parser library by James Clark. It has been a hugely
|
||||
successful project, but suffers from a couple of rather major flaws.
|
||||
Firstly it is a proprietary API, designed before the SAX API was
|
||||
conceived, which means that it is not easily replaceable by other
|
||||
streaming parsers. Secondly it's callbacks are subrefs. This doesn't
|
||||
sound like much of an issue, but unfortunately leads to code like:
|
||||
|
||||
sub handle_start {
|
||||
my ($e, $el, %attrs) = @_;
|
||||
if ($el eq 'foo') {
|
||||
$e->{inside_foo}++; # BAD! $e is an XML::Parser::Expat object.
|
||||
}
|
||||
}
|
||||
|
||||
As you can see, we're using the $e object to hold our state
|
||||
information, which is a bad idea because we don't own that object - we
|
||||
didn't create it. It's an internal object of XML::Parser, that happens
|
||||
to be a hashref. We could all too easily overwrite XML::Parser internal
|
||||
state variables by using this, or Clark could change it to an array ref
|
||||
(not that he would, because it would break so much code, but he could).
|
||||
|
||||
The only way currently with XML::Parser to safely maintain state is to
|
||||
use a closure:
|
||||
|
||||
my $state = MyState->new();
|
||||
$parser->setHandlers(Start => sub { handle_start($state, @_) });
|
||||
|
||||
This closure traps the $state variable, which now gets passed as the
|
||||
first parameter to your callback. Unfortunately very few people use
|
||||
this technique, as it is not documented in the XML::Parser POD files.
|
||||
|
||||
Another reason you might not want to use XML::Parser is because you
|
||||
need some feature that it doesn't provide (such as validation), or you
|
||||
might need to use a library that doesn't use expat, due to it not being
|
||||
installed on your system, or due to having a restrictive ISP. Using SAX
|
||||
allows you to work around these restrictions.
|
||||
|
||||
=head1 Introducing SAX
|
||||
|
||||
SAX stands for the Simple API for XML. And simple it really is.
|
||||
Constructing a SAX parser and passing events to handlers is done as
|
||||
simply as:
|
||||
|
||||
use XML::SAX;
|
||||
use MySAXHandler;
|
||||
|
||||
my $parser = XML::SAX::ParserFactory->parser(
|
||||
Handler => MySAXHandler->new
|
||||
);
|
||||
|
||||
$parser->parse_uri("foo.xml");
|
||||
|
||||
The important concept to grasp here is that SAX uses a factory class
|
||||
called XML::SAX::ParserFactory to create a new parser instance. The
|
||||
reason for this is so that you can support other underlying
|
||||
parser implementations for different feature sets. This is one thing
|
||||
that XML::Parser has always sorely lacked.
|
||||
|
||||
In the code above we see the parse_uri method used, but we could
|
||||
have equally well
|
||||
called parse_file, parse_string, or parse(). Please see XML::SAX::Base
|
||||
for what these methods take as parameters, but don't be fooled into
|
||||
believing parse_file takes a filename. No, it takes a file handle, a
|
||||
glob, or a subclass of IO::Handle. Beware.
|
||||
|
||||
SAX works very similarly to XML::Parser's default callback method,
|
||||
except it has one major difference: rather than setting individual
|
||||
callbacks, you create a new class in which to recieve the callbacks.
|
||||
Each callback is called as a method call on an instance of that handler
|
||||
class. An example will best demonstrate this:
|
||||
|
||||
package MySAXHandler;
|
||||
use base qw(XML::SAX::Base);
|
||||
|
||||
sub start_document {
|
||||
my ($self, $doc) = @_;
|
||||
# process document start event
|
||||
}
|
||||
|
||||
sub start_element {
|
||||
my ($self, $el) = @_;
|
||||
# process element start event
|
||||
}
|
||||
|
||||
Now, when we instantiate this as above, and parse some XML with this as
|
||||
the handler, the methods start_document and start_element will be
|
||||
called as method calls, so this would be the equivalent of directly
|
||||
calling:
|
||||
|
||||
$object->start_element($el);
|
||||
|
||||
Notice how this is different to XML::Parser's calling style, which
|
||||
calls:
|
||||
|
||||
start_element($e, $name, %attribs);
|
||||
|
||||
It's the difference between function calling and method calling which
|
||||
allows you to subclass SAX handlers which contributes to SAX being a
|
||||
powerful solution.
|
||||
|
||||
As you can see, unlike XML::Parser, we have to define a new package in
|
||||
which to do our processing (there are hacks you can do to make this
|
||||
uneccessary, but I'll leave figuring those out to the experts). The
|
||||
biggest benefit of this is that you maintain your own state variable
|
||||
($self in the above example) thus freeing you of the concerns listed
|
||||
above. It is also an improvement in maintainability - you can place the
|
||||
code in a separate file if you wish to, and your callback methods are
|
||||
always called the same thing, rather than having to choose a suitable
|
||||
name for them as you had to with XML::Parser. This is an obvious win.
|
||||
|
||||
SAX parsers are also very flexible in how you pass a handler to them.
|
||||
You can use a constructor parameter as we saw above, or we can pass the
|
||||
handler directly in the call to one of the parse methods:
|
||||
|
||||
$parser->parse(Handler => $handler,
|
||||
Source => { SystemId => "foo.xml" });
|
||||
# or...
|
||||
$parser->parse_file($fh, Handler => $handler);
|
||||
|
||||
This flexibility allows for one parser to be used in many different
|
||||
scenarios throughout your script (though one shouldn't feel pressure to
|
||||
use this method, as parser construction is generally not a time
|
||||
consuming process).
|
||||
|
||||
=head1 Callback Parameters
|
||||
|
||||
The only other thing you need to know to understand basic SAX is the
|
||||
structure of the parameters passed to each of the callbacks. In
|
||||
XML::Parser, all parameters are passed as multiple options to the
|
||||
callbacks, so for example the Start callback would be called as
|
||||
my_start($e, $name, %attributes), and the PI callback would be called
|
||||
as my_processing_instruction($e, $target, $data). In SAX, every
|
||||
callback is passed a hash reference, containing entries that define our
|
||||
"node". The key callbacks and the structures they receive are:
|
||||
|
||||
=head2 start_element
|
||||
|
||||
The start_element handler is called whenever a parser sees an opening
|
||||
tag. It is passed an element structure consisting of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item LocalName
|
||||
|
||||
The name of the element minus any namespace prefix it may
|
||||
have come with in the document.
|
||||
|
||||
=item NamespaceURI
|
||||
|
||||
The URI of the namespace associated with this element,
|
||||
or the empty string for none.
|
||||
|
||||
=item Attributes
|
||||
|
||||
A set of attributes as described below.
|
||||
|
||||
=item Name
|
||||
|
||||
The name of the element as it was seen in the document (i.e.
|
||||
including any prefix associated with it)
|
||||
|
||||
=item Prefix
|
||||
|
||||
The prefix used to qualify this element's namespace, or the
|
||||
empty string if none.
|
||||
|
||||
=back
|
||||
|
||||
The B<Attributes> are a hash reference, keyed by what we have called
|
||||
"James Clark" notation. This means that the attribute name has been
|
||||
expanded to include any associated namespace URI, and put together as
|
||||
{ns}name, where "ns" is the expanded namespace URI of the attribute if
|
||||
and only if the attribute had a prefix, and "name" is the LocalName of
|
||||
the attribute.
|
||||
|
||||
The value of each entry in the attributes hash is another hash
|
||||
structure consisting of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item LocalName
|
||||
|
||||
The name of the attribute minus any namespace prefix it may have
|
||||
come with in the document.
|
||||
|
||||
=item NamespaceURI
|
||||
|
||||
The URI of the namespace associated with this attribute. If the
|
||||
attribute had no prefix, then this consists of just the empty string.
|
||||
|
||||
=item Name
|
||||
|
||||
The attribute's name as it appeared in the document, including any
|
||||
namespace prefix.
|
||||
|
||||
=item Prefix
|
||||
|
||||
The prefix used to qualify this attribute's namepace, or the
|
||||
empty string if none.
|
||||
|
||||
=item Value
|
||||
|
||||
The value of the attribute.
|
||||
|
||||
=back
|
||||
|
||||
So a full example, as output by Data::Dumper might be:
|
||||
|
||||
....
|
||||
|
||||
=head2 end_element
|
||||
|
||||
The end_element handler is called either when a parser sees a closing
|
||||
tag, or after start_element has been called for an empty element (do
|
||||
note however that a parser may if it is so inclined call characters
|
||||
with an empty string when it sees an empty element. There is no simple
|
||||
way in SAX to determine if the parser in fact saw an empty element, a
|
||||
start and end element with no content..
|
||||
|
||||
The end_element handler receives exactly the same structure as
|
||||
start_element, minus the Attributes entry. One must note though that it
|
||||
should not be a reference to the same data as start_element receives,
|
||||
so you may change the values in start_element but this will not affect
|
||||
the values later seen by end_element.
|
||||
|
||||
=head2 characters
|
||||
|
||||
The characters callback may be called in serveral circumstances. The
|
||||
most obvious one is when seeing ordinary character data in the markup.
|
||||
But it is also called for text in a CDATA section, and is also called
|
||||
in other situations. A SAX parser has to make no guarantees whatsoever
|
||||
about how many times it may call characters for a stretch of text in an
|
||||
XML document - it may call once, or it may call once for every
|
||||
character in the text. In order to work around this it is often
|
||||
important for the SAX developer to use a bundling technique, where text
|
||||
is gathered up and processed in one of the other callbacks. This is not
|
||||
always necessary, but it is a worthwhile technique to learn, which we
|
||||
will cover in XML::SAX::Advanced (when I get around to writing it).
|
||||
|
||||
The characters handler is called with a very simple structure - a hash
|
||||
reference consisting of just one entry:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Data
|
||||
|
||||
The text data that was received.
|
||||
|
||||
=back
|
||||
|
||||
=head2 comment
|
||||
|
||||
The comment callback is called for comment text. Unlike with
|
||||
C<characters()>, the comment callback *must* be invoked just once for an
|
||||
entire comment string. It receives a single simple structure - a hash
|
||||
reference containing just one entry:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Data
|
||||
|
||||
The text of the comment.
|
||||
|
||||
=back
|
||||
|
||||
=head2 processing_instruction
|
||||
|
||||
The processing instruction handler is called for all processing
|
||||
instructions in the document. Note that these processing instructions
|
||||
may appear before the document root element, or after it, or anywhere
|
||||
where text and elements would normally appear within the document,
|
||||
according to the XML specification.
|
||||
|
||||
The handler is passed a structure containing just two entries:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Target
|
||||
|
||||
The target of the processing instrcution
|
||||
|
||||
=item Data
|
||||
|
||||
The text data in the processing instruction. Can be an empty
|
||||
string for a processing instruction that has no data element.
|
||||
For example E<lt>?wiggle?E<gt> is a perfectly valid processing instruction.
|
||||
|
||||
=back
|
||||
|
||||
=head1 Tip of the iceberg
|
||||
|
||||
What we have discussed above is really the tip of the SAX iceberg. And
|
||||
so far it looks like there's not much of interest to SAX beyond what we
|
||||
have seen with XML::Parser. But it does go much further than that, I
|
||||
promise.
|
||||
|
||||
People who hate Object Oriented code for the sake of it may be thinking
|
||||
here that creating a new package just to parse something is a waste
|
||||
when they've been parsing things just fine up to now using procedural
|
||||
code. But there's reason to all this madness. And that reason is SAX
|
||||
Filters.
|
||||
|
||||
As you saw right at the very start, to let the parser know about our
|
||||
class, we pass it an instance of our class as the Handler to the
|
||||
parser. But now imagine what would happen if our class could also take
|
||||
a Handler option, and simply do some processing and pass on our data
|
||||
further down the line? That in a nutshell is how SAX filters work. It's
|
||||
Unix pipes for the 21st century!
|
||||
|
||||
There are two downsides to this. Number 1 - writing SAX filters can be
|
||||
tricky. If you look into the future and read the advanced tutorial I'm
|
||||
writing, you'll see that Handler can come in several shapes and sizes.
|
||||
So making sure your filter does the right thing can be tricky.
|
||||
Secondly, constructing complex filter chains can be difficult, and
|
||||
simple thinking tells us that we only get one pass at our document,
|
||||
when often we'll need more than that.
|
||||
|
||||
Luckily though, those downsides have been fixed by the release of two
|
||||
very cool modules. What's even better is that I didn't write either of
|
||||
them!
|
||||
|
||||
The first module is XML::SAX::Base. This is a VITAL SAX module that
|
||||
acts as a base class for all SAX parsers and filters. It provides an
|
||||
abstraction away from calling the handler methods, that makes sure your
|
||||
filter or parser does the right thing, and it does it FAST. So, if you
|
||||
ever need to write a SAX filter, which if you're processing XML -> XML,
|
||||
or XML -> HTML, then you probably do, then you need to be writing it as
|
||||
a subclass of XML::SAX::Base. Really - this is advice not to ignore
|
||||
lightly. I will not go into the details of writing a SAX filter here.
|
||||
Kip Hampton, the author of XML::SAX::Base has covered this nicely in
|
||||
his article on XML.com here <URI>.
|
||||
|
||||
To construct SAX pipelines, Barrie Slaymaker, a long time Perl hacker
|
||||
whose modules you will probably have heard of or used, wrote a very
|
||||
clever module called XML::SAX::Machines. This combines some really
|
||||
clever SAX filter-type modules, with a construction toolkit for filters
|
||||
that makes building pipelines easy. But before we see how it makes
|
||||
things easy, first lets see how tricky it looks to build complex SAX
|
||||
filter pipelines.
|
||||
|
||||
use XML::SAX::ParserFactory;
|
||||
use XML::Filter::Filter1;
|
||||
use XML::Filter::Filter2;
|
||||
use XML::SAX::Writer;
|
||||
|
||||
my $output_string;
|
||||
my $writer = XML::SAX::Writer->new(Output => \$output_string);
|
||||
my $filter2 = XML::SAX::Filter2->new(Handler => $writer);
|
||||
my $filter1 = XML::SAX::Filter1->new(Handler => $filter2);
|
||||
my $parser = XML::SAX::ParserFactory->parser(Handler => $filter1);
|
||||
|
||||
$parser->parse_uri("foo.xml");
|
||||
|
||||
This is a lot easier with XML::SAX::Machines:
|
||||
|
||||
use XML::SAX::Machines qw(Pipeline);
|
||||
|
||||
my $output_string;
|
||||
my $parser = Pipeline(
|
||||
XML::SAX::Filter1 => XML::SAX::Filter2 => \$output_string
|
||||
);
|
||||
|
||||
$parser->parse_uri("foo.xml");
|
||||
|
||||
One of the main benefits of XML::SAX::Machines is that the pipelines
|
||||
are constructed in natural order, rather than the reverse order we saw
|
||||
with manual pipeline construction. XML::SAX::Machines takes care of all
|
||||
the internals of pipe construction, providing you at the end with just
|
||||
a parser you can use (and you can re-use the same parser as many times
|
||||
as you need to).
|
||||
|
||||
Just a final tip. If you ever get stuck and are confused about what is
|
||||
being passed from one SAX filter or parser to the next, then
|
||||
Devel::TraceSAX will come to your rescue. This perl debugger plugin
|
||||
will allow you to dump the SAX stream of events as it goes by. Usage is
|
||||
really very simple just call your perl script that uses SAX as follows:
|
||||
|
||||
$ perl -d:TraceSAX <scriptname>
|
||||
|
||||
And preferably pipe the output to a pager of some sort, such as more or
|
||||
less. The output is extremely verbose, but should help clear some
|
||||
issues up.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Matt Sergeant, matt@sergeant.org
|
||||
|
||||
$Id$
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,230 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::ParserFactory;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
$VERSION = '1.01';
|
||||
|
||||
use Symbol qw(gensym);
|
||||
use XML::SAX;
|
||||
use XML::SAX::Exception;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %params = @_; # TODO : Fix this in spec.
|
||||
my $self = bless \%params, $class;
|
||||
$self->{KnownParsers} = XML::SAX->parsers();
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parser {
|
||||
my $self = shift;
|
||||
my @parser_params = @_;
|
||||
if (!ref($self)) {
|
||||
$self = $self->new();
|
||||
}
|
||||
|
||||
my $parser_class = $self->_parser_class();
|
||||
|
||||
my $version = '';
|
||||
if ($parser_class =~ s/\s*\(([\d\.]+)\)\s*$//) {
|
||||
$version = " $1";
|
||||
}
|
||||
|
||||
if (!$parser_class->can('new')) {
|
||||
eval "require $parser_class $version;";
|
||||
die $@ if $@;
|
||||
}
|
||||
|
||||
return $parser_class->new(@parser_params);
|
||||
}
|
||||
|
||||
sub require_feature {
|
||||
my $self = shift;
|
||||
my ($feature) = @_;
|
||||
$self->{RequiredFeatures}{$feature}++;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _parser_class {
|
||||
my $self = shift;
|
||||
|
||||
# First try ParserPackage
|
||||
if ($XML::SAX::ParserPackage) {
|
||||
return $XML::SAX::ParserPackage;
|
||||
}
|
||||
|
||||
# Now check if required/preferred is there
|
||||
if ($self->{RequiredFeatures}) {
|
||||
my %required = %{$self->{RequiredFeatures}};
|
||||
# note - we never go onto the next try (ParserDetails.ini),
|
||||
# because if we can't provide the requested feature
|
||||
# we need to throw an exception.
|
||||
PARSER:
|
||||
foreach my $parser (reverse @{$self->{KnownParsers}}) {
|
||||
foreach my $feature (keys %required) {
|
||||
if (!exists $parser->{Features}{$feature}) {
|
||||
next PARSER;
|
||||
}
|
||||
}
|
||||
# got here - all features must exist!
|
||||
return $parser->{Name};
|
||||
}
|
||||
# TODO : should this be NotSupported() ?
|
||||
throw XML::SAX::Exception (
|
||||
Message => "Unable to provide required features",
|
||||
);
|
||||
}
|
||||
|
||||
# Next try SAX.ini
|
||||
for my $dir (@INC) {
|
||||
my $fh = gensym();
|
||||
if (open($fh, "$dir/SAX.ini")) {
|
||||
my $param_list = XML::SAX->_parse_ini_file($fh);
|
||||
my $params = $param_list->[0]->{Features};
|
||||
if ($params->{ParserPackage}) {
|
||||
return $params->{ParserPackage};
|
||||
}
|
||||
else {
|
||||
# we have required features (or nothing?)
|
||||
PARSER:
|
||||
foreach my $parser (reverse @{$self->{KnownParsers}}) {
|
||||
foreach my $feature (keys %$params) {
|
||||
if (!exists $parser->{Features}{$feature}) {
|
||||
next PARSER;
|
||||
}
|
||||
}
|
||||
return $parser->{Name};
|
||||
}
|
||||
XML::SAX->do_warn("Unable to provide SAX.ini required features. Using fallback\n");
|
||||
}
|
||||
last; # stop after first INI found
|
||||
}
|
||||
}
|
||||
|
||||
if (@{$self->{KnownParsers}}) {
|
||||
return $self->{KnownParsers}[-1]{Name};
|
||||
}
|
||||
else {
|
||||
return "XML::SAX::PurePerl"; # backup plan!
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::SAX::ParserFactory - Obtain a SAX parser
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use XML::SAX::ParserFactory;
|
||||
use XML::SAX::XYZHandler;
|
||||
my $handler = XML::SAX::XYZHandler->new();
|
||||
my $p = XML::SAX::ParserFactory->parser(Handler => $handler);
|
||||
$p->parse_uri("foo.xml");
|
||||
# or $p->parse_string("<foo/>") or $p->parse_file($fh);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
XML::SAX::ParserFactory is a factory class for providing an application
|
||||
with a Perl SAX2 XML parser. It is akin to DBI - a front end for other
|
||||
parser classes. Each new SAX2 parser installed will register itself
|
||||
with XML::SAX, and then it will become available to all applications
|
||||
that use XML::SAX::ParserFactory to obtain a SAX parser.
|
||||
|
||||
Unlike DBI however, XML/SAX parsers almost all work alike (especially
|
||||
if they subclass XML::SAX::Base, as they should), so rather than
|
||||
specifying the parser you want in the call to C<parser()>, XML::SAX
|
||||
has several ways to automatically choose which parser to use:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * $XML::SAX::ParserPackage
|
||||
|
||||
If this package variable is set, then this package is C<require()>d
|
||||
and an instance of this package is returned by calling the C<new()>
|
||||
class method in that package. If it cannot be loaded or there is
|
||||
an error, an exception will be thrown. The variable can also contain
|
||||
a version number:
|
||||
|
||||
$XML::SAX::ParserPackage = "XML::SAX::Expat (0.72)";
|
||||
|
||||
And the number will be treated as a minimum version number.
|
||||
|
||||
=item * Required features
|
||||
|
||||
It is possible to require features from the parsers. For example, you
|
||||
may wish for a parser that supports validation via a DTD. To do that,
|
||||
use the following code:
|
||||
|
||||
use XML::SAX::ParserFactory;
|
||||
my $factory = XML::SAX::ParserFactory->new();
|
||||
$factory->require_feature('http://xml.org/sax/features/validation');
|
||||
my $parser = $factory->parser(...);
|
||||
|
||||
Alternatively, specify the required features in the call to the
|
||||
ParserFactory constructor:
|
||||
|
||||
my $factory = XML::SAX::ParserFactory->new(
|
||||
RequiredFeatures => {
|
||||
'http://xml.org/sax/features/validation' => 1,
|
||||
}
|
||||
);
|
||||
|
||||
If the features you have asked for are unavailable (for example the
|
||||
user might not have a validating parser installed), then an
|
||||
exception will be thrown.
|
||||
|
||||
The list of known parsers is searched in reverse order, so it will
|
||||
always return the last installed parser that supports all of your
|
||||
requested features (Note: this is subject to change if someone
|
||||
comes up with a better way of making this work).
|
||||
|
||||
=item * SAX.ini
|
||||
|
||||
ParserFactory will search @INC for a file called SAX.ini, which
|
||||
is in a simple format:
|
||||
|
||||
# a comment looks like this,
|
||||
; or like this, and are stripped anywhere in the file
|
||||
key = value # SAX.in contains key/value pairs.
|
||||
|
||||
All whitespace is non-significant.
|
||||
|
||||
This file can contain either a line:
|
||||
|
||||
ParserPackage = MyParserModule (1.02)
|
||||
|
||||
Where MyParserModule is the module to load and use for the parser,
|
||||
and the number in brackets is a minimum version to load.
|
||||
|
||||
Or you can list required features:
|
||||
|
||||
http://xml.org/sax/features/validation = 1
|
||||
|
||||
And each feature with a true value will be required.
|
||||
|
||||
=item * Fallback
|
||||
|
||||
If none of the above works, the last parser installed on the user's
|
||||
system will be used. The XML::SAX package ships with a pure perl
|
||||
XML parser, XML::SAX::PurePerl, so that there will always be a
|
||||
fallback parser.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Matt Sergeant, matt@sergeant.org
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This is free software, you may use it and distribute it under the same
|
||||
terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,95 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::DebugHandler;
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %opts = @_;
|
||||
return bless \%opts, $class;
|
||||
}
|
||||
|
||||
# DocumentHandler
|
||||
|
||||
sub set_document_locator {
|
||||
my $self = shift;
|
||||
print "set_document_locator\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{set_document_locator}++;
|
||||
}
|
||||
|
||||
sub start_document {
|
||||
my $self = shift;
|
||||
print "start_document\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{start_document}++;
|
||||
}
|
||||
|
||||
sub end_document {
|
||||
my $self = shift;
|
||||
print "end_document\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{end_document}++;
|
||||
}
|
||||
|
||||
sub start_element {
|
||||
my $self = shift;
|
||||
print "start_element\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{start_element}++;
|
||||
}
|
||||
|
||||
sub end_element {
|
||||
my $self = shift;
|
||||
print "end_element\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{end_element}++;
|
||||
}
|
||||
|
||||
sub characters {
|
||||
my $self = shift;
|
||||
print "characters\n" if $ENV{DEBUG_XML};
|
||||
# warn "Char: ", $_[0]->{Data}, "\n";
|
||||
$self->{seen}{characters}++;
|
||||
}
|
||||
|
||||
sub processing_instruction {
|
||||
my $self = shift;
|
||||
print "processing_instruction\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{processing_instruction}++;
|
||||
}
|
||||
|
||||
sub ignorable_whitespace {
|
||||
my $self = shift;
|
||||
print "ignorable_whitespace\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{ignorable_whitespace}++;
|
||||
}
|
||||
|
||||
# LexHandler
|
||||
|
||||
sub comment {
|
||||
my $self = shift;
|
||||
print "comment\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{comment}++;
|
||||
}
|
||||
|
||||
# DTDHandler
|
||||
|
||||
sub notation_decl {
|
||||
my $self = shift;
|
||||
print "notation_decl\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{notation_decl}++;
|
||||
}
|
||||
|
||||
sub unparsed_entity_decl {
|
||||
my $self = shift;
|
||||
print "unparsed_entity_decl\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{entity_decl}++;
|
||||
}
|
||||
|
||||
# EntityResolver
|
||||
|
||||
sub resolve_entity {
|
||||
my $self = shift;
|
||||
print "resolve_entity\n" if $ENV{DEBUG_XML};
|
||||
$self->{seen}{resolve_entity}++;
|
||||
return '';
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,180 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl;
|
||||
|
||||
use strict;
|
||||
use XML::SAX::PurePerl::Productions qw($PubidChar);
|
||||
|
||||
sub doctypedecl {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $data = $reader->data(9);
|
||||
if ($data =~ /^<!DOCTYPE/) {
|
||||
$reader->move_along(9);
|
||||
$self->skip_whitespace($reader) ||
|
||||
$self->parser_error("No whitespace after doctype declaration", $reader);
|
||||
|
||||
my $root_name = $self->Name($reader) ||
|
||||
$self->parser_error("Doctype declaration has no root element name", $reader);
|
||||
|
||||
if ($self->skip_whitespace($reader)) {
|
||||
# might be externalid...
|
||||
my %dtd = $self->ExternalID($reader);
|
||||
# TODO: Call SAX event
|
||||
}
|
||||
|
||||
$self->skip_whitespace($reader);
|
||||
|
||||
$self->InternalSubset($reader);
|
||||
|
||||
$reader->match('>') or $self->parser_error("Doctype not closed", $reader);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub ExternalID {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $data = $reader->data(6);
|
||||
|
||||
if ($data =~ /^SYSTEM/) {
|
||||
$reader->move_along(6);
|
||||
$self->skip_whitespace($reader) ||
|
||||
$self->parser_error("No whitespace after SYSTEM identifier", $reader);
|
||||
return (SYSTEM => $self->SystemLiteral($reader));
|
||||
}
|
||||
elsif ($data =~ /^PUBLIC/) {
|
||||
$reader->move_along(6);
|
||||
$self->skip_whitespace($reader) ||
|
||||
$self->parser_error("No whitespace after PUBLIC identifier", $reader);
|
||||
|
||||
my $quote = $self->quote($reader) ||
|
||||
$self->parser_error("Not a quote character in PUBLIC identifier", $reader);
|
||||
|
||||
my $data = $reader->data;
|
||||
my $pubid = '';
|
||||
while(1) {
|
||||
$self->parser_error("EOF while looking for end of PUBLIC identifiier", $reader)
|
||||
unless length($data);
|
||||
|
||||
if ($data =~ /^([^$quote]*)$quote/) {
|
||||
$pubid .= $1;
|
||||
$reader->move_along(length($1) + 1);
|
||||
last;
|
||||
}
|
||||
else {
|
||||
$pubid .= $data;
|
||||
$reader->move_along(length($data));
|
||||
$data = $reader->data;
|
||||
}
|
||||
}
|
||||
|
||||
if ($pubid !~ /^($PubidChar)+$/) {
|
||||
$self->parser_error("Invalid characters in PUBLIC identifier", $reader);
|
||||
}
|
||||
|
||||
$self->skip_whitespace($reader) ||
|
||||
$self->parser_error("Not whitespace after PUBLIC ID in DOCTYPE", $reader);
|
||||
|
||||
return (PUBLIC => $pubid,
|
||||
SYSTEM => $self->SystemLiteral($reader));
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub SystemLiteral {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $quote = $self->quote($reader);
|
||||
|
||||
my $data = $reader->data;
|
||||
my $systemid = '';
|
||||
while (1) {
|
||||
$self->parser_error("EOF found while looking for end of Sytem Literal", $reader)
|
||||
unless length($data);
|
||||
if ($data =~ /^([^$quote]*)$quote/) {
|
||||
$systemid .= $1;
|
||||
$reader->move_along(length($1) + 1);
|
||||
return $systemid;
|
||||
}
|
||||
else {
|
||||
$systemid .= $data;
|
||||
$reader->move_along(length($data));
|
||||
$data = $reader->data;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub InternalSubset {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
return 0 unless $reader->match('[');
|
||||
|
||||
1 while $self->IntSubsetDecl($reader);
|
||||
|
||||
$reader->match(']') or $self->parser_error("No close bracket on internal subset (found: " . $reader->data, $reader);
|
||||
$self->skip_whitespace($reader);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub IntSubsetDecl {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
return $self->DeclSep($reader) || $self->markupdecl($reader);
|
||||
}
|
||||
|
||||
sub DeclSep {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
if ($self->skip_whitespace($reader)) {
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($self->PEReference($reader)) {
|
||||
return 1;
|
||||
}
|
||||
|
||||
# if ($self->ParsedExtSubset($reader)) {
|
||||
# return 1;
|
||||
# }
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub PEReference {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
return 0 unless $reader->match('%');
|
||||
|
||||
my $peref = $self->Name($reader) ||
|
||||
$self->parser_error("PEReference did not find a Name", $reader);
|
||||
# TODO - load/parse the peref
|
||||
|
||||
$reader->match(';') or $self->parser_error("Invalid token in PEReference", $reader);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub markupdecl {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
if ($self->elementdecl($reader) ||
|
||||
$self->AttlistDecl($reader) ||
|
||||
$self->EntityDecl($reader) ||
|
||||
$self->NotationDecl($reader) ||
|
||||
$self->PI($reader) ||
|
||||
$self->Comment($reader))
|
||||
{
|
||||
return 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,105 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl; # NB, not ::EncodingDetect!
|
||||
|
||||
use strict;
|
||||
|
||||
sub encoding_detect {
|
||||
my ($parser, $reader) = @_;
|
||||
|
||||
my $error = "Invalid byte sequence at start of file";
|
||||
|
||||
my $data = $reader->data;
|
||||
if ($data =~ /^\x00\x00\xFE\xFF/) {
|
||||
# BO-UCS4-be
|
||||
$reader->move_along(4);
|
||||
$reader->set_encoding('UCS-4BE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x00\x00\xFF\xFE/) {
|
||||
# BO-UCS-4-2143
|
||||
$reader->move_along(4);
|
||||
$reader->set_encoding('UCS-4-2143');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x00\x00\x00\x3C/) {
|
||||
$reader->set_encoding('UCS-4BE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x00\x00\x3C\x00/) {
|
||||
$reader->set_encoding('UCS-4-2143');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x00\x3C\x00\x00/) {
|
||||
$reader->set_encoding('UCS-4-3412');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x00\x3C\x00\x3F/) {
|
||||
$reader->set_encoding('UTF-16BE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\xFF\xFE\x00\x00/) {
|
||||
# BO-UCS-4LE
|
||||
$reader->move_along(4);
|
||||
$reader->set_encoding('UCS-4LE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\xFF\xFE/) {
|
||||
$reader->move_along(2);
|
||||
$reader->set_encoding('UTF-16LE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\xFE\xFF\x00\x00/) {
|
||||
$reader->move_along(4);
|
||||
$reader->set_encoding('UCS-4-3412');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\xFE\xFF/) {
|
||||
$reader->move_along(2);
|
||||
$reader->set_encoding('UTF-16BE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\xEF\xBB\xBF/) { # UTF-8 BOM
|
||||
$reader->move_along(3);
|
||||
$reader->set_encoding('UTF-8');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x3C\x00\x00\x00/) {
|
||||
$reader->set_encoding('UCS-4LE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x3C\x00\x3F\x00/) {
|
||||
$reader->set_encoding('UTF-16LE');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x3C\x3F\x78\x6D/) {
|
||||
# $reader->set_encoding('UTF-8');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x3C\x3F\x78/) {
|
||||
# $reader->set_encoding('UTF-8');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x3C\x3F/) {
|
||||
# $reader->set_encoding('UTF-8');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x3C/) {
|
||||
# $reader->set_encoding('UTF-8');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^[\x20\x09\x0A\x0D]+\x3C[^\x3F]/) {
|
||||
# $reader->set_encoding('UTF-8');
|
||||
return;
|
||||
}
|
||||
elsif ($data =~ /^\x4C\x6F\xA7\x94/) {
|
||||
$reader->set_encoding('EBCDIC');
|
||||
return;
|
||||
}
|
||||
|
||||
warn("Unable to recognise encoding of this document");
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,67 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Exception;
|
||||
|
||||
use strict;
|
||||
|
||||
use overload '""' => "stringify";
|
||||
|
||||
use vars qw/$StackTrace/;
|
||||
|
||||
$StackTrace = $ENV{XML_DEBUG} || 0;
|
||||
|
||||
sub throw {
|
||||
my $class = shift;
|
||||
die $class->new(@_);
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %opts = @_;
|
||||
die "Invalid options" unless exists $opts{Message};
|
||||
|
||||
if ($opts{reader}) {
|
||||
return bless { Message => $opts{Message},
|
||||
Exception => undef, # not sure what this is for!!!
|
||||
ColumnNumber => $opts{reader}->column,
|
||||
LineNumber => $opts{reader}->line,
|
||||
PublicId => $opts{reader}->public_id,
|
||||
SystemId => $opts{reader}->system_id,
|
||||
$StackTrace ? (StackTrace => stacktrace()) : (),
|
||||
}, $class;
|
||||
}
|
||||
return bless { Message => $opts{Message},
|
||||
Exception => undef, # not sure what this is for!!!
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub stringify {
|
||||
my $self = shift;
|
||||
local $^W;
|
||||
return $self->{Message} . " [Ln: " . $self->{LineNumber} .
|
||||
", Col: " . $self->{ColumnNumber} . "]" .
|
||||
($StackTrace ? stackstring($self->{StackTrace}) : "") . "\n";
|
||||
}
|
||||
|
||||
sub stacktrace {
|
||||
my $i = 2;
|
||||
my @fulltrace;
|
||||
while (my @trace = caller($i++)) {
|
||||
my %hash;
|
||||
@hash{qw(Package Filename Line)} = @trace[0..2];
|
||||
push @fulltrace, \%hash;
|
||||
}
|
||||
return \@fulltrace;
|
||||
}
|
||||
|
||||
sub stackstring {
|
||||
my $stacktrace = shift;
|
||||
my $string = "\nFrom:\n";
|
||||
foreach my $current (@$stacktrace) {
|
||||
$string .= $current->{Filename} . " Line: " . $current->{Line} . "\n";
|
||||
}
|
||||
return $string;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,28 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl;
|
||||
use strict;
|
||||
|
||||
sub chr_ref {
|
||||
my $n = shift;
|
||||
if ($n < 0x80) {
|
||||
return chr ($n);
|
||||
}
|
||||
elsif ($n < 0x800) {
|
||||
return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));
|
||||
}
|
||||
elsif ($n < 0x10000) {
|
||||
return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),
|
||||
(($n & 0x3f) | 0x80));
|
||||
}
|
||||
elsif ($n < 0x110000)
|
||||
{
|
||||
return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),
|
||||
((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,147 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Productions;
|
||||
|
||||
use Exporter;
|
||||
@ISA = ('Exporter');
|
||||
@EXPORT_OK = qw($S $Char $VersionNum $BaseChar $Ideographic
|
||||
$Extender $Digit $CombiningChar $EncNameStart $EncNameEnd $NameChar $CharMinusDash
|
||||
$PubidChar $Any $SingleChar);
|
||||
|
||||
### WARNING!!! All productions here must *only* match a *single* character!!! ###
|
||||
|
||||
BEGIN {
|
||||
$S = qr/[\x20\x09\x0D\x0A]/;
|
||||
|
||||
$CharMinusDash = qr/[^-]/x;
|
||||
|
||||
$Any = qr/ . /xms;
|
||||
|
||||
$VersionNum = qr/ [a-zA-Z0-9_.:-]+ /x;
|
||||
|
||||
$EncNameStart = qr/ [A-Za-z] /x;
|
||||
$EncNameEnd = qr/ [A-Za-z0-9\._-] /x;
|
||||
|
||||
$PubidChar = qr/ [\x20\x0D\x0Aa-zA-Z0-9'()\+,.\/:=\?;!*\#@\$_\%-] /x;
|
||||
|
||||
if ($] < 5.006) {
|
||||
eval <<' PERL';
|
||||
$Char = qr/^ [\x09\x0A\x0D\x20-\x7F]|([\xC0-\xFD][\x80-\xBF]+) $/x;
|
||||
|
||||
$SingleChar = qr/^$Char$/;
|
||||
|
||||
$BaseChar = qr/ [\x41-\x5A\x61-\x7A]|([\xC0-\xFD][\x80-\xBF]+) /x;
|
||||
|
||||
$Extender = qr/ \xB7 /x;
|
||||
|
||||
$Digit = qr/ [\x30-\x39] /x;
|
||||
|
||||
# can't do this one without unicode
|
||||
# $CombiningChar = qr/^$/msx;
|
||||
|
||||
$NameChar = qr/^ (?: $BaseChar | $Digit | [._:-] | $Extender )+ $/x;
|
||||
PERL
|
||||
die $@ if $@;
|
||||
}
|
||||
else {
|
||||
eval <<' PERL';
|
||||
|
||||
use utf8; # for 5.6
|
||||
|
||||
$Char = qr/^ [\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}] $/x;
|
||||
|
||||
$SingleChar = qr/^$Char$/;
|
||||
|
||||
$BaseChar = qr/
|
||||
[\x{0041}-\x{005A}\x{0061}-\x{007A}\x{00C0}-\x{00D6}\x{00D8}-\x{00F6}] |
|
||||
[\x{00F8}-\x{00FF}\x{0100}-\x{0131}\x{0134}-\x{013E}\x{0141}-\x{0148}] |
|
||||
[\x{014A}-\x{017E}\x{0180}-\x{01C3}\x{01CD}-\x{01F0}\x{01F4}-\x{01F5}] |
|
||||
[\x{01FA}-\x{0217}\x{0250}-\x{02A8}\x{02BB}-\x{02C1}\x{0386}\x{0388}-\x{038A}] |
|
||||
[\x{038C}\x{038E}-\x{03A1}\x{03A3}-\x{03CE}\x{03D0}-\x{03D6}\x{03DA}] |
|
||||
[\x{03DC}\x{03DE}\x{03E0}\x{03E2}-\x{03F3}\x{0401}-\x{040C}\x{040E}-\x{044F}] |
|
||||
[\x{0451}-\x{045C}\x{045E}-\x{0481}\x{0490}-\x{04C4}\x{04C7}-\x{04C8}] |
|
||||
[\x{04CB}-\x{04CC}\x{04D0}-\x{04EB}\x{04EE}-\x{04F5}\x{04F8}-\x{04F9}] |
|
||||
[\x{0531}-\x{0556}\x{0559}\x{0561}-\x{0586}\x{05D0}-\x{05EA}\x{05F0}-\x{05F2}] |
|
||||
[\x{0621}-\x{063A}\x{0641}-\x{064A}\x{0671}-\x{06B7}\x{06BA}-\x{06BE}] |
|
||||
[\x{06C0}-\x{06CE}\x{06D0}-\x{06D3}\x{06D5}\x{06E5}-\x{06E6}\x{0905}-\x{0939}] |
|
||||
[\x{093D}\x{0958}-\x{0961}\x{0985}-\x{098C}\x{098F}-\x{0990}] |
|
||||
[\x{0993}-\x{09A8}\x{09AA}-\x{09B0}\x{09B2}\x{09B6}-\x{09B9}\x{09DC}-\x{09DD}] |
|
||||
[\x{09DF}-\x{09E1}\x{09F0}-\x{09F1}\x{0A05}-\x{0A0A}\x{0A0F}-\x{0A10}] |
|
||||
[\x{0A13}-\x{0A28}\x{0A2A}-\x{0A30}\x{0A32}-\x{0A33}\x{0A35}-\x{0A36}] |
|
||||
[\x{0A38}-\x{0A39}\x{0A59}-\x{0A5C}\x{0A5E}\x{0A72}-\x{0A74}\x{0A85}-\x{0A8B}] |
|
||||
[\x{0A8D}\x{0A8F}-\x{0A91}\x{0A93}-\x{0AA8}\x{0AAA}-\x{0AB0}] |
|
||||
[\x{0AB2}-\x{0AB3}\x{0AB5}-\x{0AB9}\x{0ABD}\x{0AE0}\x{0B05}-\x{0B0C}] |
|
||||
[\x{0B0F}-\x{0B10}\x{0B13}-\x{0B28}\x{0B2A}-\x{0B30}\x{0B32}-\x{0B33}] |
|
||||
[\x{0B36}-\x{0B39}\x{0B3D}\x{0B5C}-\x{0B5D}\x{0B5F}-\x{0B61}\x{0B85}-\x{0B8A}] |
|
||||
[\x{0B8E}-\x{0B90}\x{0B92}-\x{0B95}\x{0B99}-\x{0B9A}\x{0B9C}] |
|
||||
[\x{0B9E}-\x{0B9F}\x{0BA3}-\x{0BA4}\x{0BA8}-\x{0BAA}\x{0BAE}-\x{0BB5}] |
|
||||
[\x{0BB7}-\x{0BB9}\x{0C05}-\x{0C0C}\x{0C0E}-\x{0C10}\x{0C12}-\x{0C28}] |
|
||||
[\x{0C2A}-\x{0C33}\x{0C35}-\x{0C39}\x{0C60}-\x{0C61}\x{0C85}-\x{0C8C}] |
|
||||
[\x{0C8E}-\x{0C90}\x{0C92}-\x{0CA8}\x{0CAA}-\x{0CB3}\x{0CB5}-\x{0CB9}\x{0CDE}] |
|
||||
[\x{0CE0}-\x{0CE1}\x{0D05}-\x{0D0C}\x{0D0E}-\x{0D10}\x{0D12}-\x{0D28}] |
|
||||
[\x{0D2A}-\x{0D39}\x{0D60}-\x{0D61}\x{0E01}-\x{0E2E}\x{0E30}\x{0E32}-\x{0E33}] |
|
||||
[\x{0E40}-\x{0E45}\x{0E81}-\x{0E82}\x{0E84}\x{0E87}-\x{0E88}\x{0E8A}] |
|
||||
[\x{0E8D}\x{0E94}-\x{0E97}\x{0E99}-\x{0E9F}\x{0EA1}-\x{0EA3}\x{0EA5}\x{0EA7}] |
|
||||
[\x{0EAA}-\x{0EAB}\x{0EAD}-\x{0EAE}\x{0EB0}\x{0EB2}-\x{0EB3}\x{0EBD}] |
|
||||
[\x{0EC0}-\x{0EC4}\x{0F40}-\x{0F47}\x{0F49}-\x{0F69}\x{10A0}-\x{10C5}] |
|
||||
[\x{10D0}-\x{10F6}\x{1100}\x{1102}-\x{1103}\x{1105}-\x{1107}\x{1109}] |
|
||||
[\x{110B}-\x{110C}\x{110E}-\x{1112}\x{113C}\x{113E}\x{1140}\x{114C}\x{114E}] |
|
||||
[\x{1150}\x{1154}-\x{1155}\x{1159}\x{115F}-\x{1161}\x{1163}\x{1165}] |
|
||||
[\x{1167}\x{1169}\x{116D}-\x{116E}\x{1172}-\x{1173}\x{1175}\x{119E}\x{11A8}] |
|
||||
[\x{11AB}\x{11AE}-\x{11AF}\x{11B7}-\x{11B8}\x{11BA}\x{11BC}-\x{11C2}] |
|
||||
[\x{11EB}\x{11F0}\x{11F9}\x{1E00}-\x{1E9B}\x{1EA0}-\x{1EF9}\x{1F00}-\x{1F15}] |
|
||||
[\x{1F18}-\x{1F1D}\x{1F20}-\x{1F45}\x{1F48}-\x{1F4D}\x{1F50}-\x{1F57}] |
|
||||
[\x{1F59}\x{1F5B}\x{1F5D}\x{1F5F}-\x{1F7D}\x{1F80}-\x{1FB4}\x{1FB6}-\x{1FBC}] |
|
||||
[\x{1FBE}\x{1FC2}-\x{1FC4}\x{1FC6}-\x{1FCC}\x{1FD0}-\x{1FD3}] |
|
||||
[\x{1FD6}-\x{1FDB}\x{1FE0}-\x{1FEC}\x{1FF2}-\x{1FF4}\x{1FF6}-\x{1FFC}] |
|
||||
[\x{2126}\x{212A}-\x{212B}\x{212E}\x{2180}-\x{2182}\x{3041}-\x{3094}] |
|
||||
[\x{30A1}-\x{30FA}\x{3105}-\x{312C}\x{AC00}-\x{D7A3}]
|
||||
/x;
|
||||
|
||||
$Extender = qr/
|
||||
[\x{00B7}\x{02D0}\x{02D1}\x{0387}\x{0640}\x{0E46}\x{0EC6}\x{3005}\x{3031}-\x{3035}\x{309D}-\x{309E}\x{30FC}-\x{30FE}]
|
||||
/x;
|
||||
|
||||
$Digit = qr/
|
||||
[\x{0030}-\x{0039}\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{0966}-\x{096F}] |
|
||||
[\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}] |
|
||||
[\x{0BE7}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}] |
|
||||
[\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}]
|
||||
/x;
|
||||
|
||||
$CombiningChar = qr/
|
||||
[\x{0300}-\x{0345}\x{0360}-\x{0361}\x{0483}-\x{0486}\x{0591}-\x{05A1}] |
|
||||
[\x{05A3}-\x{05B9}\x{05BB}-\x{05BD}\x{05BF}\x{05C1}-\x{05C2}\x{05C4}] |
|
||||
[\x{064B}-\x{0652}\x{0670}\x{06D6}-\x{06DC}\x{06DD}-\x{06DF}\x{06E0}-\x{06E4}] |
|
||||
[\x{06E7}-\x{06E8}\x{06EA}-\x{06ED}\x{0901}-\x{0903}\x{093C}] |
|
||||
[\x{093E}-\x{094C}\x{094D}\x{0951}-\x{0954}\x{0962}-\x{0963}\x{0981}-\x{0983}] |
|
||||
[\x{09BC}\x{09BE}\x{09BF}\x{09C0}-\x{09C4}\x{09C7}-\x{09C8}] |
|
||||
[\x{09CB}-\x{09CD}\x{09D7}\x{09E2}-\x{09E3}\x{0A02}\x{0A3C}\x{0A3E}\x{0A3F}] |
|
||||
[\x{0A40}-\x{0A42}\x{0A47}-\x{0A48}\x{0A4B}-\x{0A4D}\x{0A70}-\x{0A71}] |
|
||||
[\x{0A81}-\x{0A83}\x{0ABC}\x{0ABE}-\x{0AC5}\x{0AC7}-\x{0AC9}\x{0ACB}-\x{0ACD}] |
|
||||
[\x{0B01}-\x{0B03}\x{0B3C}\x{0B3E}-\x{0B43}\x{0B47}-\x{0B48}] |
|
||||
[\x{0B4B}-\x{0B4D}\x{0B56}-\x{0B57}\x{0B82}-\x{0B83}\x{0BBE}-\x{0BC2}] |
|
||||
[\x{0BC6}-\x{0BC8}\x{0BCA}-\x{0BCD}\x{0BD7}\x{0C01}-\x{0C03}\x{0C3E}-\x{0C44}] |
|
||||
[\x{0C46}-\x{0C48}\x{0C4A}-\x{0C4D}\x{0C55}-\x{0C56}\x{0C82}-\x{0C83}] |
|
||||
[\x{0CBE}-\x{0CC4}\x{0CC6}-\x{0CC8}\x{0CCA}-\x{0CCD}\x{0CD5}-\x{0CD6}] |
|
||||
[\x{0D02}-\x{0D03}\x{0D3E}-\x{0D43}\x{0D46}-\x{0D48}\x{0D4A}-\x{0D4D}\x{0D57}] |
|
||||
[\x{0E31}\x{0E34}-\x{0E3A}\x{0E47}-\x{0E4E}\x{0EB1}\x{0EB4}-\x{0EB9}] |
|
||||
[\x{0EBB}-\x{0EBC}\x{0EC8}-\x{0ECD}\x{0F18}-\x{0F19}\x{0F35}\x{0F37}\x{0F39}] |
|
||||
[\x{0F3E}\x{0F3F}\x{0F71}-\x{0F84}\x{0F86}-\x{0F8B}\x{0F90}-\x{0F95}] |
|
||||
[\x{0F97}\x{0F99}-\x{0FAD}\x{0FB1}-\x{0FB7}\x{0FB9}\x{20D0}-\x{20DC}\x{20E1}] |
|
||||
[\x{302A}-\x{302F}\x{3099}\x{309A}]
|
||||
/x;
|
||||
|
||||
$Ideographic = qr/
|
||||
[\x{4E00}-\x{9FA5}\x{3007}\x{3021}-\x{3029}]
|
||||
/x;
|
||||
|
||||
$NameChar = qr/^ (?: $BaseChar | $Ideographic | $Digit | [._:-] | $CombiningChar | $Extender )+ $/x;
|
||||
PERL
|
||||
|
||||
die $@ if $@;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,136 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Reader;
|
||||
|
||||
use strict;
|
||||
use XML::SAX::PurePerl::Reader::URI;
|
||||
use Exporter ();
|
||||
|
||||
use vars qw(@ISA @EXPORT_OK);
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(
|
||||
EOF
|
||||
BUFFER
|
||||
LINE
|
||||
COLUMN
|
||||
ENCODING
|
||||
XML_VERSION
|
||||
);
|
||||
|
||||
use constant EOF => 0;
|
||||
use constant BUFFER => 1;
|
||||
use constant LINE => 2;
|
||||
use constant COLUMN => 3;
|
||||
use constant ENCODING => 4;
|
||||
use constant SYSTEM_ID => 5;
|
||||
use constant PUBLIC_ID => 6;
|
||||
use constant XML_VERSION => 7;
|
||||
|
||||
require XML::SAX::PurePerl::Reader::Stream;
|
||||
require XML::SAX::PurePerl::Reader::String;
|
||||
|
||||
if ($] >= 5.007002) {
|
||||
require XML::SAX::PurePerl::Reader::UnicodeExt;
|
||||
}
|
||||
else {
|
||||
require XML::SAX::PurePerl::Reader::NoUnicodeExt;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $thing = shift;
|
||||
|
||||
# try to figure if this $thing is a handle of some sort
|
||||
if (ref($thing) && UNIVERSAL::isa($thing, 'IO::Handle')) {
|
||||
return XML::SAX::PurePerl::Reader::Stream->new($thing)->init;
|
||||
}
|
||||
my $ioref;
|
||||
if (tied($thing)) {
|
||||
my $class = ref($thing);
|
||||
no strict 'refs';
|
||||
$ioref = $thing if defined &{"${class}::TIEHANDLE"};
|
||||
}
|
||||
else {
|
||||
eval {
|
||||
$ioref = *{$thing}{IO};
|
||||
};
|
||||
undef $@;
|
||||
}
|
||||
if ($ioref) {
|
||||
return XML::SAX::PurePerl::Reader::Stream->new($thing)->init;
|
||||
}
|
||||
|
||||
if ($thing =~ /</) {
|
||||
# assume it's a string
|
||||
return XML::SAX::PurePerl::Reader::String->new($thing)->init;
|
||||
}
|
||||
|
||||
# assume it is a uri
|
||||
return XML::SAX::PurePerl::Reader::URI->new($thing)->init;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->[LINE] = 1;
|
||||
$self->[COLUMN] = 1;
|
||||
$self->read_more;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub data {
|
||||
my ($self, $min_length) = (@_, 1);
|
||||
if (length($self->[BUFFER]) < $min_length) {
|
||||
$self->read_more;
|
||||
}
|
||||
return $self->[BUFFER];
|
||||
}
|
||||
|
||||
sub match {
|
||||
my ($self, $char) = @_;
|
||||
my $data = $self->data;
|
||||
if (substr($data, 0, 1) eq $char) {
|
||||
$self->move_along(1);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub public_id {
|
||||
my $self = shift;
|
||||
@_ and $self->[PUBLIC_ID] = shift;
|
||||
$self->[PUBLIC_ID];
|
||||
}
|
||||
|
||||
sub system_id {
|
||||
my $self = shift;
|
||||
@_ and $self->[SYSTEM_ID] = shift;
|
||||
$self->[SYSTEM_ID];
|
||||
}
|
||||
|
||||
sub line {
|
||||
shift->[LINE];
|
||||
}
|
||||
|
||||
sub column {
|
||||
shift->[COLUMN];
|
||||
}
|
||||
|
||||
sub get_encoding {
|
||||
my $self = shift;
|
||||
return $self->[ENCODING];
|
||||
}
|
||||
|
||||
sub get_xml_version {
|
||||
my $self = shift;
|
||||
return $self->[XML_VERSION];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Parser::PurePerl::Reader - Abstract Reader factory class
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,25 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Reader;
|
||||
use strict;
|
||||
|
||||
sub set_raw_stream {
|
||||
# no-op
|
||||
}
|
||||
|
||||
sub switch_encoding_stream {
|
||||
my ($fh, $encoding) = @_;
|
||||
throw XML::SAX::Exception::Parse (
|
||||
Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding",
|
||||
) if $encoding !~ /(ASCII|UTF\-?8)/i;
|
||||
}
|
||||
|
||||
sub switch_encoding_string {
|
||||
my (undef, $encoding) = @_;
|
||||
throw XML::SAX::Exception::Parse (
|
||||
Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding",
|
||||
) if $encoding !~ /(ASCII|UTF\-?8)/i;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,84 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Reader::Stream;
|
||||
|
||||
use strict;
|
||||
use vars qw(@ISA);
|
||||
|
||||
use XML::SAX::PurePerl::Reader qw(
|
||||
EOF
|
||||
BUFFER
|
||||
LINE
|
||||
COLUMN
|
||||
ENCODING
|
||||
XML_VERSION
|
||||
);
|
||||
use XML::SAX::Exception;
|
||||
|
||||
@ISA = ('XML::SAX::PurePerl::Reader');
|
||||
|
||||
# subclassed by adding 1 to last element
|
||||
use constant FH => 8;
|
||||
use constant BUFFER_SIZE => 4096;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $ioref = shift;
|
||||
XML::SAX::PurePerl::Reader::set_raw_stream($ioref);
|
||||
my @parts;
|
||||
@parts[FH, LINE, COLUMN, BUFFER, EOF, XML_VERSION] =
|
||||
($ioref, 1, 0, '', 0, '1.0');
|
||||
return bless \@parts, $class;
|
||||
}
|
||||
|
||||
sub read_more {
|
||||
my $self = shift;
|
||||
my $buf;
|
||||
my $bytesread = read($self->[FH], $buf, BUFFER_SIZE);
|
||||
if ($bytesread) {
|
||||
$self->[BUFFER] .= $buf;
|
||||
return 1;
|
||||
}
|
||||
elsif (defined($bytesread)) {
|
||||
$self->[EOF]++;
|
||||
return 0;
|
||||
}
|
||||
else {
|
||||
throw XML::SAX::Exception::Parse(
|
||||
Message => "Error reading from filehandle: $!",
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub move_along {
|
||||
my $self = shift;
|
||||
my $discarded = substr($self->[BUFFER], 0, $_[0], '');
|
||||
|
||||
# Wish I could skip this lot - tells us where we are in the file
|
||||
my $lines = $discarded =~ tr/\n//;
|
||||
$self->[LINE] += $lines;
|
||||
if ($lines) {
|
||||
$discarded =~ /\n([^\n]*)$/;
|
||||
$self->[COLUMN] = length($1);
|
||||
}
|
||||
else {
|
||||
$self->[COLUMN] += $_[0];
|
||||
}
|
||||
}
|
||||
|
||||
sub set_encoding {
|
||||
my $self = shift;
|
||||
my ($encoding) = @_;
|
||||
# warn("set encoding to: $encoding\n");
|
||||
XML::SAX::PurePerl::Reader::switch_encoding_stream($self->[FH], $encoding);
|
||||
XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding);
|
||||
$self->[ENCODING] = $encoding;
|
||||
}
|
||||
|
||||
sub bytepos {
|
||||
my $self = shift;
|
||||
tell($self->[FH]);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,78 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Reader::String;
|
||||
|
||||
use strict;
|
||||
use vars qw(@ISA);
|
||||
|
||||
use XML::SAX::PurePerl::Reader qw(
|
||||
LINE
|
||||
COLUMN
|
||||
BUFFER
|
||||
ENCODING
|
||||
EOF
|
||||
);
|
||||
|
||||
@ISA = ('XML::SAX::PurePerl::Reader');
|
||||
|
||||
use constant DISCARDED => 8;
|
||||
use constant STRING => 9;
|
||||
use constant USED => 10;
|
||||
use constant CHUNK_SIZE => 2048;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $string = shift;
|
||||
my @parts;
|
||||
@parts[BUFFER, EOF, LINE, COLUMN, DISCARDED, STRING, USED] =
|
||||
('', 0, 1, 0, 0, $string, 0);
|
||||
return bless \@parts, $class;
|
||||
}
|
||||
|
||||
sub read_more () {
|
||||
my $self = shift;
|
||||
if ($self->[USED] >= length($self->[STRING])) {
|
||||
$self->[EOF]++;
|
||||
return 0;
|
||||
}
|
||||
my $bytes = CHUNK_SIZE;
|
||||
if ($bytes > (length($self->[STRING]) - $self->[USED])) {
|
||||
$bytes = (length($self->[STRING]) - $self->[USED]);
|
||||
}
|
||||
$self->[BUFFER] .= substr($self->[STRING], $self->[USED], $bytes);
|
||||
$self->[USED] += $bytes;
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub move_along {
|
||||
my($self, $bytes) = @_;
|
||||
my $discarded = substr($self->[BUFFER], 0, $bytes, '');
|
||||
$self->[DISCARDED] += length($discarded);
|
||||
|
||||
# Wish I could skip this lot - tells us where we are in the file
|
||||
my $lines = $discarded =~ tr/\n//;
|
||||
$self->[LINE] += $lines;
|
||||
if ($lines) {
|
||||
$discarded =~ /\n([^\n]*)$/;
|
||||
$self->[COLUMN] = length($1);
|
||||
}
|
||||
else {
|
||||
$self->[COLUMN] += $_[0];
|
||||
}
|
||||
}
|
||||
|
||||
sub set_encoding {
|
||||
my $self = shift;
|
||||
my ($encoding) = @_;
|
||||
|
||||
XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding, "utf-8");
|
||||
$self->[ENCODING] = $encoding;
|
||||
}
|
||||
|
||||
sub bytepos {
|
||||
my $self = shift;
|
||||
$self->[DISCARDED];
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,57 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Reader::URI;
|
||||
|
||||
use strict;
|
||||
|
||||
use XML::SAX::PurePerl::Reader;
|
||||
use File::Temp qw(tempfile);
|
||||
use Symbol;
|
||||
|
||||
## NOTE: This is *not* a subclass of Reader. It just returns Stream or String
|
||||
## Reader objects depending on what it's capabilities are.
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $uri = shift;
|
||||
# request the URI
|
||||
if (-e $uri && -f _) {
|
||||
my $fh = gensym;
|
||||
open($fh, $uri) || die "Cannot open file $uri : $!";
|
||||
return XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||
}
|
||||
elsif ($uri =~ /^file:(.*)$/ && -e $1 && -f _) {
|
||||
my $file = $1;
|
||||
my $fh = gensym;
|
||||
open($fh, $file) || die "Cannot open file $file : $!";
|
||||
return XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||
}
|
||||
else {
|
||||
# request URI, return String reader
|
||||
require LWP::UserAgent;
|
||||
my $ua = LWP::UserAgent->new;
|
||||
$ua->agent("Perl/XML/SAX/PurePerl/1.0 " . $ua->agent);
|
||||
|
||||
my $req = HTTP::Request->new(GET => $uri);
|
||||
|
||||
my $fh = tempfile();
|
||||
|
||||
my $callback = sub {
|
||||
my ($data, $response, $protocol) = @_;
|
||||
print $fh $data;
|
||||
};
|
||||
|
||||
my $res = $ua->request($req, $callback, 4096);
|
||||
|
||||
if ($res->is_success) {
|
||||
seek($fh, 0, 0);
|
||||
return XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||
}
|
||||
else {
|
||||
die "LWP Request Failed";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,23 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl::Reader;
|
||||
use strict;
|
||||
|
||||
use Encode ();
|
||||
|
||||
sub set_raw_stream {
|
||||
my ($fh) = @_;
|
||||
binmode($fh, ":bytes");
|
||||
}
|
||||
|
||||
sub switch_encoding_stream {
|
||||
my ($fh, $encoding) = @_;
|
||||
binmode($fh, ":encoding($encoding)");
|
||||
}
|
||||
|
||||
sub switch_encoding_string {
|
||||
$_[0] = Encode::decode($_[1], $_[0]);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,22 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl;
|
||||
use strict;
|
||||
|
||||
no warnings 'utf8';
|
||||
|
||||
sub chr_ref {
|
||||
return chr(shift);
|
||||
}
|
||||
|
||||
if ($] >= 5.007002) {
|
||||
require Encode;
|
||||
|
||||
Encode::define_alias( "UTF-16" => "UCS-2" );
|
||||
Encode::define_alias( "UTF-16BE" => "UCS-2" );
|
||||
Encode::define_alias( "UTF-16LE" => "ucs-2le" );
|
||||
Encode::define_alias( "UTF16LE" => "ucs-2le" );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,129 @@
|
||||
# $Id$
|
||||
|
||||
package XML::SAX::PurePerl;
|
||||
|
||||
use strict;
|
||||
use XML::SAX::PurePerl::Productions qw($S $VersionNum $EncNameStart $EncNameEnd);
|
||||
|
||||
sub XMLDecl {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $data = $reader->data(5);
|
||||
# warn("Looking for xmldecl in: $data");
|
||||
if ($data =~ /^<\?xml$S/o) {
|
||||
$reader->move_along(5);
|
||||
$self->skip_whitespace($reader);
|
||||
|
||||
# get version attribute
|
||||
$self->VersionInfo($reader) ||
|
||||
$self->parser_error("XML Declaration lacks required version attribute, or version attribute does not match XML specification", $reader);
|
||||
|
||||
if (!$self->skip_whitespace($reader)) {
|
||||
my $data = $reader->data(2);
|
||||
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||
$reader->move_along(2);
|
||||
return;
|
||||
}
|
||||
|
||||
if ($self->EncodingDecl($reader)) {
|
||||
if (!$self->skip_whitespace($reader)) {
|
||||
my $data = $reader->data(2);
|
||||
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||
$reader->move_along(2);
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
$self->SDDecl($reader);
|
||||
|
||||
$self->skip_whitespace($reader);
|
||||
|
||||
my $data = $reader->data(2);
|
||||
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||
$reader->move_along(2);
|
||||
}
|
||||
else {
|
||||
# warn("first 5 bytes: ", join(',', unpack("CCCCC", $data)), "\n");
|
||||
# no xml decl
|
||||
if (!$reader->get_encoding) {
|
||||
$reader->set_encoding("UTF-8");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub VersionInfo {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $data = $reader->data(11);
|
||||
|
||||
# warn("Looking for version in $data");
|
||||
|
||||
$data =~ /^(version$S*=$S*(["'])($VersionNum)\2)/o or return 0;
|
||||
$reader->move_along(length($1));
|
||||
my $vernum = $3;
|
||||
|
||||
if ($vernum ne "1.0") {
|
||||
$self->parser_error("Only XML version 1.0 supported. Saw: '$vernum'", $reader);
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub SDDecl {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $data = $reader->data(15);
|
||||
|
||||
$data =~ /^(standalone$S*=$S*(["'])(yes|no)\2)/o or return 0;
|
||||
$reader->move_along(length($1));
|
||||
my $yesno = $3;
|
||||
|
||||
if ($yesno eq 'yes') {
|
||||
$self->{standalone} = 1;
|
||||
}
|
||||
else {
|
||||
$self->{standalone} = 0;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub EncodingDecl {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $data = $reader->data(12);
|
||||
|
||||
$data =~ /^(encoding$S*=$S*(["'])($EncNameStart$EncNameEnd*)\2)/o or return 0;
|
||||
$reader->move_along(length($1));
|
||||
my $encoding = $3;
|
||||
|
||||
$reader->set_encoding($encoding);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub TextDecl {
|
||||
my ($self, $reader) = @_;
|
||||
|
||||
my $data = $reader->data(6);
|
||||
$data =~ /^<\?xml$S+/ or return;
|
||||
$reader->move_along(5);
|
||||
$self->skip_whitespace($reader);
|
||||
|
||||
if ($self->VersionInfo($reader)) {
|
||||
$self->skip_whitespace($reader) ||
|
||||
$self->parser_error("Lack of whitespace after version attribute in text declaration", $reader);
|
||||
}
|
||||
|
||||
$self->EncodingDecl($reader) ||
|
||||
$self->parser_error("Encoding declaration missing from external entity text declaration", $reader);
|
||||
|
||||
$self->skip_whitespace($reader);
|
||||
|
||||
$data = $reader->data(2);
|
||||
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user