JoJo
/
LeOS-GSI
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

creation

LeOS-20
harvey186 2023-12-11 11:15:04 +01:00
parent 2cc0a1af17
commit 3c914cfbe3
583 changed files with 0 additions and 177691 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
vendor/LeOS/config/common.mk vendored
View File

@ -1,70 +0,0 @@
# Overlay
PRODUCT_ENFORCE_RRO_EXCLUDED_OVERLAYS += vendor/ponces/overlay
PRODUCT_PACKAGE_OVERLAYS += \
vendor/ponces/overlay/common
ifneq ($(TARGET_BUILD_VARIANT),eng)
# Disable extra StrictMode features on all non-engineering builds
PRODUCT_SYSTEM_PROPERTIES += persist.sys.strictmode.disable=true
endif
# Enable SIP+VoIP on all targets
PRODUCT_COPY_FILES += \
frameworks/native/data/etc/android.software.sip.voip.xml:$(TARGET_COPY_OUT_PRODUCT)/etc/permissions/android.software.sip.voip.xml
# Face Unlock
TARGET_FACE_UNLOCK_SUPPORTED ?= $(TARGET_SUPPORTS_64_BIT_APPS)
ifeq ($(TARGET_FACE_UNLOCK_SUPPORTED),true)
PRODUCT_PACKAGES += \
ParanoidSense
PRODUCT_SYSTEM_EXT_PROPERTIES += \
ro.face.sense_service=true
PRODUCT_COPY_FILES += \
frameworks/native/data/etc/android.hardware.biometrics.face.xml:$(TARGET_COPY_OUT_SYSTEM)/etc/permissions/android.hardware.biometrics.face.xml
endif
# Enforce privapp-permissions whitelist
PRODUCT_SYSTEM_PROPERTIES += \
ro.control_privapp_permissions=enforce
# Power whitelist
PRODUCT_COPY_FILES += \
vendor/ponces/config/permissions/custom-power-whitelist.xml:system/etc/sysconfig/custom-power-whitelist.xml
# Do not include art debug targets
PRODUCT_ART_TARGET_INCLUDE_DEBUG_BUILD := false
# Strip the local variable table and the local variable type table to reduce
# the size of the system image. This has no bearing on stack traces, but will
# leave less information available via JDWP.
PRODUCT_MINIMIZE_JAVA_DEBUG_INFO := true
# One Handed mode
PRODUCT_PRODUCT_PROPERTIES += \
ro.support_one_handed_mode?=true
# The set of packages we want to force 'speed' compilation on.
PRODUCT_DEXPREOPT_SPEED_APPS += \
TrebuchetQuickStep \
Settings \
SystemUI
PRODUCT_SYSTEM_DEFAULT_PROPERTIES += \
dalvik.vm.systemuicompilerfilter=speed
# Enable lockscreen live wallpaper
PRODUCT_SYSTEM_DEFAULT_PROPERTIES += \
persist.wm.debug.lockscreen_live_wallpaper=true
# Use gestures by default
PRODUCT_PRODUCT_PROPERTIES += \
ro.boot.vendor.overlay.theme=com.android.internal.systemui.navbar.gestural
# Packages
$(call inherit-product, vendor/ponces/config/packages.mk)
# RRO Overlays
$(call inherit-product, vendor/ponces/config/rro_overlays.mk)

10
vendor/LeOS/config/packages.mk vendored
View File

@ -1,10 +0,0 @@
# Required packages
PRODUCT_PACKAGES += \
Stk \
ThemePicker \
ThemesStub
# Trebuchet
PRODUCT_PACKAGES += \
TrebuchetQuickStep

10
vendor/LeOS/config/rro_overlays.mk vendored
View File

@ -1,10 +0,0 @@
# RRO Overlays
PRODUCT_PACKAGES += \
CertificationOverlay \
ConfigOverlay \
DocumentsUIOverlay \
FrameworksOverlay \
Launcher3Overlay \
SettingsProviderOverlay \
SystemUIOverlay \
WifiOverlay

22
vendor/LeOS/overlay/common/frameworks/base/libs/WindowManager/Shell/res/values/config.xml vendored
View File

@ -1,22 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!--
Copyright (C) 2020 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<!-- Determines whether the shell features all run on another thread. This is to be overrided
by the resources of the app using the Shell library. -->
<bool name="config_enableShellMainThread">true</bool>
</resources>

46
vendor/LeOS/overlay/common/packages/apps/Settings/res/values/config.xml vendored
View File

@ -1,46 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<!-- When true enable gesture setting. -->
<bool name="config_gesture_settings_enabled">true</bool>
<!-- Package name for the wallpaper picker activity. -->
<string name="config_wallpaper_picker_package" translatable="false">com.android.wallpaper</string>
<!-- Fully-qualified class name for the wallpaper picker activity. -->
<string name="config_wallpaper_picker_class" translatable="false">com.android.customization.picker.CustomizationPickerActivity</string>
<!-- Fully-qualified class name for the styles & wallpaper picker activity. -->
<string name="config_styles_and_wallpaper_picker_class" translatable="false">com.android.customization.picker.CustomizationPickerActivity</string>
<!-- Whether memory from app_info_settings is available or not. -->
<bool name="config_show_app_info_settings_memory">true</bool>
<!-- Action name for the wallpaper picker activity. -->
<string name="config_wallpaper_picker_action" translatable="false">android.intent.action.MAIN</string>
<!-- Action name for the styles & wallpaper picker activity. -->
<string name="config_styles_and_wallpaper_picker_action" translatable="false">android.intent.action.MAIN</string>
<!-- Whether or not device header widget tile should display in device info page -->
<bool name="config_show_device_header_in_device_info">false</bool>
<!-- Whether to show a preference item for mobile plan -->
<bool name="config_show_mobile_plan">false</bool>
<!-- Whether to display Cloned Apps page in Settings (Settings > Apps > Cloned Apps).-->
<bool name="config_cloned_apps_page_enabled">true</bool>
</resources>

33
vendor/LeOS/overlay/common/packages/apps/ThemePicker/res_override/values/override.xml vendored
View File

@ -1,33 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<!-- List of packages whose icons are used to preview the icon shape for a theme. These are
typically GMS apps so they should be available in GMS devices. -->
<array name="icon_shape_preview_packages">
<item>com.google.android.gm</item>
<item>com.google.android.googlequicksearchbox</item>
<item>com.google.android.apps.photos</item>
<item>com.google.android.apps.docs</item>
<item>com.google.android.youtube</item>
<item>com.android.vending</item>
<item>com.android.settings</item>
<item>com.android.deskclock</item>
<item>com.android.messaging</item>
<item>com.android.contacts</item>
<item>com.android.dialer</item>
<item>com.android.email</item>
</array>
</resources>

7
vendor/LeOS/rro_overlays/CertificationOverlay/Android.bp vendored
View File

@ -1,7 +0,0 @@
runtime_resource_overlay {
name: "CertificationOverlay",
theme: "CertificationOverlay",
certificate: "platform",
sdk_version: "current",
product_specific: true
}

9
vendor/LeOS/rro_overlays/CertificationOverlay/AndroidManifest.xml vendored
View File

@ -1,9 +0,0 @@
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="com.android.certification.overlay">
<application android:label="CertificationOverlay" android:hasCode="false"/>
<overlay
android:priority="1"
android:targetName="CertificationOverlay"
android:targetPackage="android"
android:isStatic="true"/>
</manifest>

28
vendor/LeOS/rro_overlays/CertificationOverlay/res/values/config.xml vendored
View File

@ -1,28 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<resources>
<string-array name="config_certifiedBuildProperties" translatable="false">
<!-- Build.PRODUCT -->
<item>MTKAC70DTI</item>
<!-- Build.DEVICE -->
<item>ac70dti</item>
<!-- Build.MANUFACTURER -->
<item>Archos</item>
<!-- Build.BRAND -->
<item>archos</item>
<!-- Build.MODEL -->
<item>Archos 70d Titanium</item>
<!-- Build.FINGERPRINT -->
<item>archos/MTKAC70DTI/ac70dti:7.0/NRD90M/20170602.033254:user/release-keys</item>
<!-- Build.SECURITY_PATCH -->
<item>2017-06-02</item>
<!-- Build.DEVICE_INITIAL_SDK_INT -->
<item>24</item>
</string-array>
</resources>

6
vendor/LeOS/rro_overlays/DocumentsUIOverlay/Android.bp vendored
View File

@ -1,6 +0,0 @@
runtime_resource_overlay {
name: "DocumentsUIOverlay",
certificate: "platform",
sdk_version: "current",
product_specific: true
}

9
vendor/LeOS/rro_overlays/DocumentsUIOverlay/AndroidManifest.xml vendored
View File

@ -1,9 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="com.ponces.android.documentsui.overlay">
<overlay
android:priority="1"
android:targetPackage="com.android.documentsui"
android:targetName="DocumentsUICustomization"
android:isStatic="true"/>
</manifest>

18
vendor/LeOS/rro_overlays/DocumentsUIOverlay/res/values/config.xml vendored
View File

@ -1,18 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<string name="default_root_uri" translatable="false">content://com.android.externalstorage.documents/root/primary</string>
</resources>

6
vendor/LeOS/rro_overlays/FrameworksOverlay/Android.bp vendored
View File

@ -1,6 +0,0 @@
runtime_resource_overlay {
name: "FrameworksOverlay",
certificate: "platform",
sdk_version: "current",
product_specific: true
}

9
vendor/LeOS/rro_overlays/FrameworksOverlay/AndroidManifest.xml vendored
View File

@ -1,9 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="com.ponces.android.frameworks.overlay">
<application android:label="FrameworksOverlay" android:hasCode="false"/>
<overlay
android:priority="1"
android:targetPackage="android"
android:isStatic="true"/>
</manifest>

18
vendor/LeOS/rro_overlays/FrameworksOverlay/res/color/config_progress_background_tint.xml vendored
View File

@ -1,18 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<selector xmlns:android="http://schemas.android.com/apk/res/android">
<item android:color="?android:attr/colorControlActivated" />
</selector>

120
vendor/LeOS/rro_overlays/FrameworksOverlay/res/values/config.xml vendored
View File

@ -1,120 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<!-- Package name(s) containing location provider support.
These packages can contain services implementing location providers,
such as the Geocode Provider, Network Location Provider, and Fused
Location Provider.
The signatures of packages named below and installed in the system
image are "allowed" signatures.
The location framework checks ALL installed packages if they provide
an implementation of a specific location provider and compares the
signature of the package with the list of allowed signatures.
The location framework has support for installation of new or
updated location providers at run-time. However the new package must
have a signature that matches the signature of at least one package
on this list which is installed in the system image.
The chosen package for the specific location provider does not
depend on the order of this list. -->
<string-array name="config_locationProviderPackageNames" translatable="false">
<!-- The standard AOSP fused location provider -->
<item>com.android.location.fused</item>
<!-- The MicroG Unified location provider -->
<item>org.microg.nlp</item>
</string-array>
<string-array name="config_locationExtraPackageNames" translatable="false">
<!-- Bluetooth -->
<item>com.android.bluetooth</item>
<!-- TeleService -->
<item>com.android.phone</item>
<!-- CneApp -->
<item>com.qualcomm.qti.cne</item>
<!-- ImsService -->
<item>com.shannon.imsservice</item>
<!-- MediaTek ImsService -->
<item>com.mediatek.ims</item>
<!-- OmniJaws -->
<item>org.omnirom.omnijaws</item>
<!-- SystemUI -->
<item>com.android.systemui</item>
<!-- Tethering -->
<item>com.android.networkstack.tethering</item>
</string-array>
<!-- Set this to true to enable the platform's auto-power-save modes like doze and
app standby. These are not enabled by default because they require a standard
cloud-to-device messaging service for apps to interact correctly with the modes
(such as to be able to deliver an instant message to the device even when it is
dozing). This should be enabled if you have such services and expect apps to
correctly use them when installed on your device. Otherwise, keep this disabled
so that applications can still use their own mechanisms. -->
<bool name="config_enableAutoPowerModes">true</bool>
<!-- Whether Multiuser UI should be shown -->
<bool name="config_enableMultiUserUI">true</bool>
<!-- Maximum number of supported users -->
<integer name="config_multiuserMaximumUsers">4</integer>
<!-- Whether action menu items should be displayed in ALLCAPS or not.
Defaults to true. If this is not appropriate for specific locales
it should be disabled in that locale's resources. -->
<bool name="config_buttonTextAllCaps">false</bool>
<!-- Pixel -->
<bool name="config_swipe_up_gesture_setting_available">true</bool>
<bool name="config_smart_battery_available">true</bool>
<!-- Flag indicating whether round icons should be parsed from the application manifest. -->
<bool name="config_useRoundIcon">true</bool>
<!-- Specifies the path that is used by AdaptiveIconDrawable class to crop launcher icons. -->
<string name="config_icon_mask" translatable="false">"M50 0C77.6 0 100 22.4 100 50C100 77.6 77.6 100 50 100C22.4 100 0 77.6 0 50C0 22.4 22.4 0 50 0Z"</string>
<!-- Whether safe headphone volume is enabled or not (country specific). -->
<bool name="config_safe_media_volume_enabled">false</bool>
<!-- Turn on dark theme by default -->
<integer name="config_defaultNightMode">2</integer>
<!-- Boolean indicating whether the HWC setColorTransform function can be performed efficiently
in hardware. -->
<bool name="config_setColorTransformAccelerated">true</bool>
<!-- Wallpaper cropper package. Used as the default cropper if the active launcher doesn't
handle wallpaper cropping.
-->
<string name="config_wallpaperCropperPackage" translatable="false">com.android.wallpaper</string>
<!-- Default component for QR code scanner -->
<string name="config_defaultQrCodeComponent" translatable="false">org.lineageos.aperture/.QrScannerActivity</string>
<!-- Whether or not to enable the lock screen entry point for the QR code scanner. -->
<bool name="config_enableQrCodeScannerOnLockScreen">true</bool>
<!-- The type of the light sensor to be used by the display framework for things like
auto-brightness. If unset, then it just gets the default sensor of type TYPE_LIGHT. -->
<string name="config_displayLightSensorType" translatable="false">android.sensor.light</string>
<!-- Define device configs on boot -->
<string-array name="global_device_configs_override">
<!-- Enable app cloning -->
<item>app_cloning/cloned_apps_enabled=true</item>
<item>app_cloning/delete_all_app_clones_enabled=true</item>
<item>app_cloning/enable_app_cloning_building_blocks=true</item>
</string-array>
</resources>

7
vendor/LeOS/rro_overlays/SettingsProviderOverlay/Android.bp vendored
View File

@ -1,7 +0,0 @@
runtime_resource_overlay {
name: "SettingsProviderOverlay",
theme: "SettingsProviderOverlay",
certificate: "platform",
sdk_version: "current",
product_specific: true
}

9
vendor/LeOS/rro_overlays/SettingsProviderOverlay/AndroidManifest.xml vendored
View File

@ -1,9 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="com.ponces.android.providers.settings.overlay">
<application android:label="SettingsProviderOverlay" android:hasCode="false"/>
<overlay
android:priority="1"
android:targetPackage="com.android.providers.settings"
android:isStatic="true"/>
</manifest>

30
vendor/LeOS/rro_overlays/SettingsProviderOverlay/res/values/defaults.xml vendored
View File

@ -1,30 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<!-- Display -->
<bool name="def_one_handed_mode_enabled">true</bool>
<bool name="def_screen_brightness_automatic_mode">true</bool>
<!-- Connectivity -->
<bool name="def_wifi_on">true</bool>
<bool name="def_bluetooth_on">false</bool>
<!-- Initial value for the Settings.Secure.IMMERSIVE_MODE_CONFIRMATIONS setting,
which is a comma separated list of packages that no longer need confirmation
for immersive mode.
Override to disable immersive mode confirmation for certain packages. -->
<string name="def_immersive_mode_confirmations" translatable="false">confirmed</string>
</resources>

6
vendor/LeOS/rro_overlays/SystemUIOverlay/Android.bp vendored
View File

@ -1,6 +0,0 @@
runtime_resource_overlay {
name: "SystemUIOverlay",
certificate: "platform",
sdk_version: "current",
product_specific: true
}

9
vendor/LeOS/rro_overlays/SystemUIOverlay/AndroidManifest.xml vendored
View File

@ -1,9 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="com.ponces.android.systemui.overlay">
<application android:label="SystemUIOverlay" android:hasCode="false"/>
<overlay
android:priority="1"
android:targetPackage="com.android.systemui"
android:isStatic="true"/>
</manifest>

39
vendor/LeOS/rro_overlays/SystemUIOverlay/res/values/config.xml vendored
View File

@ -1,39 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<!-- SystemUI Plugins that can be loaded on user builds. -->
<string-array name="config_pluginAllowlist" translatable="false">
<item>com.android.systemui</item>
<item>com.android.systemui.falcon</item>
<item>com.android.systemui.falcon.debug</item>
<item>com.android.systemui.falcon.one</item>
<item>com.android.systemui.falcon.two</item>
<item>com.android.systemui.falcon.three</item>
<item>com.android.systemui.falcon.four</item>
<item>com.android.systemui.falcon.five</item>
<item>com.android.systemui.falcon.six</item>
<item>com.android.systemui.falcon.seven</item>
<item>com.android.systemui.falcon.eight</item>
<item>com.android.systemui.falcon.nine</item>
<item>com.android.systemui.plugin.globalactions.wallet</item>
</string-array>
<!-- Whether or not lockscreen shortcuts can be customized -->
<bool name="custom_lockscreen_shortcuts_enabled" translatable="false">true</bool>
<!-- Whether or not long-pressing on keyguard will display to customize lockscreen -->
<bool name="long_press_keyguard_customize_lockscreen_enabled" translatable="false">true</bool>
</resources>

6
vendor/LeOS/rro_overlays/WifiOverlay/Android.bp vendored
View File

@ -1,6 +0,0 @@
runtime_resource_overlay {
name: "WifiOverlay",
theme: "WifiOverlay",
sdk_version: "current",
product_specific: true
}

12
vendor/LeOS/rro_overlays/WifiOverlay/AndroidManifest.xml vendored
View File

@ -1,12 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<manifest xmlns:android="http://schemas.android.com/apk/res/android"
package="com.ponces.android.wifi.resources.overlay"
android:versionCode="1"
android:versionName="1.0">
<application android:hasCode="false"/>
<overlay
android:priority="1"
android:targetPackage="com.android.wifi.resources"
android:targetName="WifiCustomization"
android:isStatic="true"/>
</manifest>

21
vendor/LeOS/rro_overlays/WifiOverlay/res/values/config.xml vendored
View File

@ -1,21 +0,0 @@
<?xml version="1.0" encoding="utf-8"?>
<!-- Copyright (C) 2019 The Android Open Source Project
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-->
<resources xmlns:xliff="urn:oasis:names:tc:xliff:document:1.2">
<!-- Whether to allow Settings or SUW to create insecure Enterprise networks where server
certificate is not validated, by not specifying a Root CA certificate and/or server domain
name. It is STRONGLY RECOMMENDED to be set to false -->
<bool translatable="false" name="config_wifiAllowInsecureEnterpriseConfigurationsForSettingsAndSUW">true</bool>
</resources>

206
vendor/LeOS/tools-leos/common/perl-base/AutoLoader.pm vendored
View File

@ -1,206 +0,0 @@
package AutoLoader;
use strict;
use 5.006_001;
our($VERSION, $AUTOLOAD);
my $is_dosish;
my $is_epoc;
my $is_vms;
my $is_macos;
BEGIN {
$is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
$is_epoc = $^O eq 'epoc';
$is_vms = $^O eq 'VMS';
$is_macos = $^O eq 'MacOS';
$VERSION = '5.74';
}
AUTOLOAD {
my $sub = $AUTOLOAD;
autoload_sub($sub);
goto &$sub;
}
sub autoload_sub {
my $sub = shift;
my $filename = AutoLoader::find_filename( $sub );
my $save = $@;
local $!; # Do not munge the value.
eval { local $SIG{__DIE__}; require $filename };
if ($@) {
if (substr($sub,-9) eq '::DESTROY') {
no strict 'refs';
*$sub = sub {};
$@ = undef;
} elsif ($@ =~ /^Can't locate/) {
# The load might just have failed because the filename was too
# long for some old SVR3 systems which treat long names as errors.
# If we can successfully truncate a long name then it's worth a go.
# There is a slight risk that we could pick up the wrong file here
# but autosplit should have warned about that when splitting.
if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
eval { local $SIG{__DIE__}; require $filename };
}
}
if ($@){
$@ =~ s/ at .*\n//;
my $error = $@;
require Carp;
Carp::croak($error);
}
}
$@ = $save;
return 1;
}
sub find_filename {
my $sub = shift;
my $filename;
# Braces used to preserve $1 et al.
{
# Try to find the autoloaded file from the package-qualified
# name of the sub. e.g., if the sub needed is
# Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
# something like '/usr/lib/perl5/Getopt/Long.pm', and the
# autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
#
# However, if @INC is a relative path, this might not work. If,
# for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
# 'lib/Getopt/Long.pm', and we want to require
# 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
# In this case, we simple prepend the 'auto/' and let the
# C<require> take care of the searching for us.
my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
$pkg =~ s#::#/#g;
if (defined($filename = $INC{"$pkg.pm"})) {
if ($is_macos) {
$pkg =~ tr#/#:#;
$filename = undef
unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
} else {
$filename = undef
unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
}
# if the file exists, then make sure that it is a
# a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
# or './lib/auto/foo/bar.al'. This avoids C<require> searching
# (and failing) to find the 'lib/auto/foo/bar.al' because it
# looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
if (defined $filename and -r $filename) {
unless ($filename =~ m|^/|s) {
if ($is_dosish) {
unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
if ($^O ne 'NetWare') {
$filename = "./$filename";
} else {
$filename = "$filename";
}
}
}
elsif ($is_epoc) {
unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
$filename = "./$filename";
}
}
elsif ($is_vms) {
# XXX todo by VMSmiths
$filename = "./$filename";
}
elsif (!$is_macos) {
$filename = "./$filename";
}
}
}
else {
$filename = undef;
}
}
unless (defined $filename) {
# let C<require> do the searching
$filename = "auto/$sub.al";
$filename =~ s#::#/#g;
}
}
return $filename;
}
sub import {
my $pkg = shift;
my $callpkg = caller;
#
# Export symbols, but not by accident of inheritance.
#
if ($pkg eq 'AutoLoader') {
if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) {
no strict 'refs';
*{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD;
}
}
#
# Try to find the autosplit index file. Eg., if the call package
# is POSIX, then $INC{POSIX.pm} is something like
# '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
# '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
#
# However, if @INC is a relative path, this might not work. If,
# for example, @INC = ('lib'), then
# $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
# 'auto/POSIX/autosplit.ix' (without the leading 'lib').
#
(my $calldir = $callpkg) =~ s#::#/#g;
my $path = $INC{$calldir . '.pm'};
if (defined($path)) {
# Try absolute path name, but only eval it if the
# transformation from module path to autosplit.ix path
# succeeded!
my $replaced_okay;
if ($is_macos) {
(my $malldir = $calldir) =~ tr#/#:#;
$replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s);
} else {
$replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#);
}
eval { require $path; } if $replaced_okay;
# If that failed, try relative path with normal @INC searching.
if (!$replaced_okay or $@) {
$path ="auto/$calldir/autosplit.ix";
eval { require $path; };
}
if ($@) {
my $error = $@;
require Carp;
Carp::carp($error);
}
}
}
sub unimport {
my $callpkg = caller;
no strict 'refs';
for my $exported (qw( AUTOLOAD )) {
my $symname = $callpkg . '::' . $exported;
undef *{ $symname } if \&{ $symname } == \&{ $exported };
*{ $symname } = \&{ $symname };
}
}
1;
__END__

619
vendor/LeOS/tools-leos/common/perl-base/Carp.pm vendored
View File

@ -1,619 +0,0 @@
package Carp;
{ use 5.006; }
use strict;
use warnings;
BEGIN {
# Very old versions of warnings.pm load Carp. This can go wrong due
# to the circular dependency. If warnings is invoked before Carp,
# then warnings starts by loading Carp, then Carp (above) tries to
# invoke warnings, and gets nothing because warnings is in the process
# of loading and hasn't defined its import method yet. If we were
# only turning on warnings ("use warnings" above) this wouldn't be too
# bad, because Carp would just gets the state of the -w switch and so
# might not get some warnings that it wanted. The real problem is
# that we then want to turn off Unicode warnings, but "no warnings
# 'utf8'" won't be effective if we're in this circular-dependency
# situation. So, if warnings.pm is an affected version, we turn
# off all warnings ourselves by directly setting ${^WARNING_BITS}.
# On unaffected versions, we turn off just Unicode warnings, via
# the proper API.
if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
${^WARNING_BITS} = "";
} else {
"warnings"->unimport("utf8");
}
}
sub _fetch_sub { # fetch sub without autovivifying
my($pack, $sub) = @_;
$pack .= '::';
# only works with top-level packages
return unless exists($::{$pack});
for ($::{$pack}) {
return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
for ($$_{$sub}) {
return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
}
}
}
# UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
# must avoid applying a regular expression to an upgraded (is_utf8)
# string. There are multiple problems, on different Perl versions,
# that require this to be avoided. All versions prior to 5.13.8 will
# load utf8_heavy.pl for the swash system, even if the regexp doesn't
# use character classes. Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
# specific problems when Carp is being invoked in the aftermath of a
# syntax error.
BEGIN {
if("$]" < 5.013011) {
*UTF8_REGEXP_PROBLEM = sub () { 1 };
} else {
*UTF8_REGEXP_PROBLEM = sub () { 0 };
}
}
# is_utf8() is essentially the utf8::is_utf8() function, which indicates
# whether a string is represented in the upgraded form (using UTF-8
# internally). As utf8::is_utf8() is only available from Perl 5.8
# onwards, extra effort is required here to make it work on Perl 5.6.
BEGIN {
if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
*is_utf8 = $sub;
} else {
# black magic for perl 5.6
*is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
}
}
# The downgrade() function defined here is to be used for attempts to
# downgrade where it is acceptable to fail. It must be called with a
# second argument that is a true value.
BEGIN {
if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
*downgrade = \&{"utf8::downgrade"};
} else {
*downgrade = sub {
my $r = "";
my $l = length($_[0]);
for(my $i = 0; $i != $l; $i++) {
my $o = ord(substr($_[0], $i, 1));
return if $o > 255;
$r .= chr($o);
}
$_[0] = $r;
};
}
}
our $VERSION = '1.42';
$VERSION =~ tr/_//d;
our $MaxEvalLen = 0;
our $Verbose = 0;
our $CarpLevel = 0;
our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
our $MaxArgNums = 8; # How many arguments to print. 0 = all.
our $RefArgFormatter = undef; # allow caller to format reference arguments
require Exporter;
our @ISA = ('Exporter');
our @EXPORT = qw(confess croak carp);
our @EXPORT_OK = qw(cluck verbose longmess shortmess);
our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
# The members of %Internal are packages that are internal to perl.
# Carp will not report errors from within these packages if it
# can. The members of %CarpInternal are internal to Perl's warning
# system. Carp will not report errors from within these packages
# either, and will not report calls *to* these packages for carp and
# croak. They replace $CarpLevel, which is deprecated. The
# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
# text and function arguments should be formatted when printed.
our %CarpInternal;
our %Internal;
# disable these by default, so they can live w/o require Carp
$CarpInternal{Carp}++;
$CarpInternal{warnings}++;
$Internal{Exporter}++;
$Internal{'Exporter::Heavy'}++;
# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
# then the following method will be called by the Exporter which knows
# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
# 'verbose'.
sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
sub _cgc {
no strict 'refs';
return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
return;
}
sub longmess {
local($!, $^E);
# Icky backwards compatibility wrapper. :-(
#
# The story is that the original implementation hard-coded the
# number of call levels to go back, so calls to longmess were off
# by one. Other code began calling longmess and expecting this
# behaviour, so the replacement has to emulate that behaviour.
my $cgc = _cgc();
my $call_pack = $cgc ? $cgc->() : caller();
if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
return longmess_heavy(@_);
}
else {
local $CarpLevel = $CarpLevel + 1;
return longmess_heavy(@_);
}
}
our @CARP_NOT;
sub shortmess {
local($!, $^E);
my $cgc = _cgc();
# Icky backwards compatibility wrapper. :-(
local @CARP_NOT = $cgc ? $cgc->() : caller();
shortmess_heavy(@_);
}
sub croak { die shortmess @_ }
sub confess { die longmess @_ }
sub carp { warn shortmess @_ }
sub cluck { warn longmess @_ }
BEGIN {
if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
("$]" >= 5.012005 && "$]" < 5.013)) {
*CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
} else {
*CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
}
}
sub caller_info {
my $i = shift(@_) + 1;
my %call_info;
my $cgc = _cgc();
{
# Some things override caller() but forget to implement the
# @DB::args part of it, which we need. We check for this by
# pre-populating @DB::args with a sentinel which no-one else
# has the address of, so that we can detect whether @DB::args
# has been properly populated. However, on earlier versions
# of perl this check tickles a bug in CORE::caller() which
# leaks memory. So we only check on fixed perls.
@DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
package DB;
@call_info{
qw(pack file line sub has_args wantarray evaltext is_require) }
= $cgc ? $cgc->($i) : caller($i);
}
unless ( defined $call_info{file} ) {
return ();
}
my $sub_name = Carp::get_subname( \%call_info );
if ( $call_info{has_args} ) {
my @args;
if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
&& ref $DB::args[0] eq ref \$i
&& $DB::args[0] == \$i ) {
@DB::args = (); # Don't let anyone see the address of $i
local $@;
my $where = eval {
my $func = $cgc or return '';
my $gv =
(_fetch_sub B => 'svref_2object' or return '')
->($func)->GV;
my $package = $gv->STASH->NAME;
my $subname = $gv->NAME;
return unless defined $package && defined $subname;
# returning CORE::GLOBAL::caller isn't useful for tracing the cause:
return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
" in &${package}::$subname";
} || '';
@args
= "** Incomplete caller override detected$where; \@DB::args were not set **";
}
else {
@args = @DB::args;
my $overflow;
if ( $MaxArgNums and @args > $MaxArgNums )
{ # More than we want to show?
$#args = $MaxArgNums - 1;
$overflow = 1;
}
@args = map { Carp::format_arg($_) } @args;
if ($overflow) {
push @args, '...';
}
}
# Push the args onto the subroutine
$sub_name .= '(' . join( ', ', @args ) . ')';
}
$call_info{sub_name} = $sub_name;
return wantarray() ? %call_info : \%call_info;
}
# Transform an argument to a function into a string.
our $in_recurse;
sub format_arg {
my $arg = shift;
if ( ref($arg) ) {
# legitimate, let's not leak it.
if (!$in_recurse &&
do {
local $@;
local $in_recurse = 1;
local $SIG{__DIE__} = sub{};
eval {$arg->can('CARP_TRACE') }
})
{
return $arg->CARP_TRACE();
}
elsif (!$in_recurse &&
defined($RefArgFormatter) &&
do {
local $@;
local $in_recurse = 1;
local $SIG{__DIE__} = sub{};
eval {$arg = $RefArgFormatter->($arg); 1}
})
{
return $arg;
}
else
{
my $sub = _fetch_sub(overload => 'StrVal');
return $sub ? &$sub($arg) : "$arg";
}
}
return "undef" if !defined($arg);
downgrade($arg, 1);
return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
$arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
my $suffix = "";
if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
substr ( $arg, $MaxArgLen - 3 ) = "";
$suffix = "...";
}
if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
for(my $i = length($arg); $i--; ) {
my $c = substr($arg, $i, 1);
my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
substr $arg, $i, 0, "\\";
next;
}
my $o = ord($c);
# This code is repeated in Regexp::CARP_TRACE()
if ($] ge 5.007_003) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
|| utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
} elsif (ord("A") == 65) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < 0x20 || $o > 0x7e;
} else { # Early EBCDIC
# 3 EBCDIC code pages supported then; all controls but one
# are the code points below SPACE. The other one is 0x5F on
# POSIX-BC; FF on the other two.
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < ord(" ") || ((ord ("^") == 106)
? $o == 0x5f
: $o == 0xff);
}
}
} else {
$arg =~ s/([\"\\\$\@])/\\$1/g;
# This is all the ASCII printables spelled-out. It is portable to all
# Perl versions and platforms (such as EBCDIC). There are other more
# compact ways to do this, but may not work everywhere every version.
$arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
}
downgrade($arg, 1);
return "\"".$arg."\"".$suffix;
}
sub Regexp::CARP_TRACE {
my $arg = "$_[0]";
downgrade($arg, 1);
if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
for(my $i = length($arg); $i--; ) {
my $o = ord(substr($arg, $i, 1));
my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
# This code is repeated in format_arg()
if ($] ge 5.007_003) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
|| utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
} elsif (ord("A") == 65) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < 0x20 || $o > 0x7e;
} else { # Early EBCDIC
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < ord(" ") || ((ord ("^") == 106)
? $o == 0x5f
: $o == 0xff);
}
}
} else {
# See comment in format_arg() about this same regex.
$arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
}
downgrade($arg, 1);
my $suffix = "";
if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
($suffix, $arg) = ($1, $2);
}
if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
substr ( $arg, $MaxArgLen - 3 ) = "";
$suffix = "...".$suffix;
}
return "qr($arg)$suffix";
}
# Takes an inheritance cache and a package and returns
# an anon hash of known inheritances and anon array of
# inheritances which consequences have not been figured
# for.
sub get_status {
my $cache = shift;
my $pkg = shift;
$cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
return @{ $cache->{$pkg} };
}
# Takes the info from caller() and figures out the name of
# the sub/require/eval
sub get_subname {
my $info = shift;
if ( defined( $info->{evaltext} ) ) {
my $eval = $info->{evaltext};
if ( $info->{is_require} ) {
return "require $eval";
}
else {
$eval =~ s/([\\\'])/\\$1/g;
return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
}
}
# this can happen on older perls when the sub (or the stash containing it)
# has been deleted
if ( !defined( $info->{sub} ) ) {
return '__ANON__::__ANON__';
}
return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
}
# Figures out what call (from the point of view of the caller)
# the long error backtrace should start at.
sub long_error_loc {
my $i;
my $lvl = $CarpLevel;
{
++$i;
my $cgc = _cgc();
my @caller = $cgc ? $cgc->($i) : caller($i);
my $pkg = $caller[0];
unless ( defined($pkg) ) {
# This *shouldn't* happen.
if (%Internal) {
local %Internal;
$i = long_error_loc();
last;
}
elsif (defined $caller[2]) {
# this can happen when the stash has been deleted
# in that case, just assume that it's a reasonable place to
# stop (the file and line data will still be intact in any
# case) - the only issue is that we can't detect if the
# deleted package was internal (so don't do that then)
# -doy
redo unless 0 > --$lvl;
last;
}
else {
return 2;
}
}
redo if $CarpInternal{$pkg};
redo unless 0 > --$lvl;
redo if $Internal{$pkg};
}
return $i - 1;
}
sub longmess_heavy {
if ( ref( $_[0] ) ) { # don't break references as exceptions
return wantarray ? @_ : $_[0];
}
my $i = long_error_loc();
return ret_backtrace( $i, @_ );
}
# Returns a full stack backtrace starting from where it is
# told.
sub ret_backtrace {
my ( $i, @error ) = @_;
my $mess;
my $err = join '', @error;
$i++;
my $tid_msg = '';
if ( defined &threads::tid ) {
my $tid = threads->tid;
$tid_msg = " thread $tid" if $tid;
}
my %i = caller_info($i);
$mess = "$err at $i{file} line $i{line}$tid_msg";
if( defined $. ) {
local $@ = '';
local $SIG{__DIE__};
eval {
CORE::die;
};
if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
$mess .= $1;
}
}
$mess .= "\.\n";
while ( my %i = caller_info( ++$i ) ) {
$mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
}
return $mess;
}
sub ret_summary {
my ( $i, @error ) = @_;
my $err = join '', @error;
$i++;
my $tid_msg = '';
if ( defined &threads::tid ) {
my $tid = threads->tid;
$tid_msg = " thread $tid" if $tid;
}
my %i = caller_info($i);
return "$err at $i{file} line $i{line}$tid_msg\.\n";
}
sub short_error_loc {
# You have to create your (hash)ref out here, rather than defaulting it
# inside trusts *on a lexical*, as you want it to persist across calls.
# (You can default it on $_[2], but that gets messy)
my $cache = {};
my $i = 1;
my $lvl = $CarpLevel;
{
my $cgc = _cgc();
my $called = $cgc ? $cgc->($i) : caller($i);
$i++;
my $caller = $cgc ? $cgc->($i) : caller($i);
if (!defined($caller)) {
my @caller = $cgc ? $cgc->($i) : caller($i);
if (@caller) {
# if there's no package but there is other caller info, then
# the package has been deleted - treat this as a valid package
# in this case
redo if defined($called) && $CarpInternal{$called};
redo unless 0 > --$lvl;
last;
}
else {
return 0;
}
}
redo if $Internal{$caller};
redo if $CarpInternal{$caller};
redo if $CarpInternal{$called};
redo if trusts( $called, $caller, $cache );
redo if trusts( $caller, $called, $cache );
redo unless 0 > --$lvl;
}
return $i - 1;
}
sub shortmess_heavy {
return longmess_heavy(@_) if $Verbose;
return @_ if ref( $_[0] ); # don't break references as exceptions
my $i = short_error_loc();
if ($i) {
ret_summary( $i, @_ );
}
else {
longmess_heavy(@_);
}
}
# If a string is too long, trims it with ...
sub str_len_trim {
my $str = shift;
my $max = shift || 0;
if ( 2 < $max and $max < length($str) ) {
substr( $str, $max - 3 ) = '...';
}
return $str;
}
# Takes two packages and an optional cache. Says whether the
# first inherits from the second.
#
# Recursive versions of this have to work to avoid certain
# possible endless loops, and when following long chains of
# inheritance are less efficient.
sub trusts {
my $child = shift;
my $parent = shift;
my $cache = shift;
my ( $known, $partial ) = get_status( $cache, $child );
# Figure out consequences until we have an answer
while ( @$partial and not exists $known->{$parent} ) {
my $anc = shift @$partial;
next if exists $known->{$anc};
$known->{$anc}++;
my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
my @found = keys %$anc_knows;
@$known{@found} = ();
push @$partial, @$anc_partial;
}
return exists $known->{$parent};
}
# Takes a package and gives a list of those trusted directly
sub trusts_directly {
my $class = shift;
no strict 'refs';
my $stash = \%{"$class\::"};
for my $var (qw/ CARP_NOT ISA /) {
# Don't try using the variable until we know it exists,
# to avoid polluting the caller's namespace.
if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
return @{$stash->{$var}}
}
}
return;
}
if(!defined($warnings::VERSION) ||
do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
# Very old versions of warnings.pm import from Carp. This can go
# wrong due to the circular dependency. If Carp is invoked before
# warnings, then Carp starts by loading warnings, then warnings
# tries to import from Carp, and gets nothing because Carp is in
# the process of loading and hasn't defined its import method yet.
# So we work around that by manually exporting to warnings here.
no strict "refs";
*{"warnings::$_"} = \&$_ foreach @EXPORT;
}
1;
__END__

21
vendor/LeOS/tools-leos/common/perl-base/Carp/Heavy.pm vendored
View File

@ -1,21 +0,0 @@
package Carp::Heavy;
use Carp ();
our $VERSION = '1.42';
$VERSION =~ tr/_//d;
# Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions
# after this point are not significant and can be ignored.
if(($Carp::VERSION || 0) < 1.12) {
my $cv = defined($Carp::VERSION) ? $Carp::VERSION : "undef";
die "Version mismatch between Carp $cv ($INC{q(Carp.pm)}) and Carp::Heavy $VERSION ($INC{q(Carp/Heavy.pm)}). Did you alter \@INC after Carp was loaded?\n";
}
1;
# Most of the machinery of Carp used to be here.
# It has been moved in Carp.pm now, but this placeholder remains for
# the benefit of modules that like to preload Carp::Heavy directly.
# This must load Carp, because some modules rely on the historical
# behaviour of Carp::Heavy loading Carp.

111
vendor/LeOS/tools-leos/common/perl-base/Config.pm vendored
View File

@ -1,111 +0,0 @@
# This file was created by configpm when Perl was built. Any changes
# made to this file will be lost the next time perl is built.
# for a description of the variables, please have a look at the
# Glossary file, as written in the Porting folder, or use the url:
# http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
package Config;
use strict;
use warnings;
use vars '%Config', '$VERSION';
$VERSION = "5.026001";
# Skip @Config::EXPORT because it only contains %Config, which we special
# case below as it's not a function. @Config::EXPORT won't change in the
# lifetime of Perl 5.
my %Export_Cache = (myconfig => 1, config_sh => 1, config_vars => 1,
config_re => 1, compile_date => 1, local_patches => 1,
bincompat_options => 1, non_bincompat_options => 1,
header_files => 1);
@Config::EXPORT = qw(%Config);
@Config::EXPORT_OK = keys %Export_Cache;
# Need to stub all the functions to make code such as print Config::config_sh
# keep working
sub bincompat_options;
sub compile_date;
sub config_re;
sub config_sh;
sub config_vars;
sub header_files;
sub local_patches;
sub myconfig;
sub non_bincompat_options;
# Define our own import method to avoid pulling in the full Exporter:
sub import {
shift;
@_ = @Config::EXPORT unless @_;
my @funcs = grep $_ ne '%Config', @_;
my $export_Config = @funcs < @_ ? 1 : 0;
no strict 'refs';
my $callpkg = caller(0);
foreach my $func (@funcs) {
die qq{"$func" is not exported by the Config module\n}
unless $Export_Cache{$func};
*{$callpkg.'::'.$func} = \&{$func};
}
*{"$callpkg\::Config"} = \%Config if $export_Config;
return;
}
die "$0: Perl lib version (5.26.1) doesn't match executable '$^X' version ($])"
unless $^V;
$^V eq 5.26.1
or die sprintf "%s: Perl lib version (5.26.1) doesn't match executable '$^X' version (%vd)", $0, $^V;
sub FETCH {
my($self, $key) = @_;
# check for cached value (which may be undef so we use exists not defined)
return exists $self->{$key} ? $self->{$key} : $self->fetch_string($key);
}
sub TIEHASH {
bless $_[1], $_[0];
}
sub DESTROY { }
sub AUTOLOAD {
require 'Config_heavy.pl';
goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
}
# tie returns the object, so the value returned to require will be true.
tie %Config, 'Config', {
archlibexp => '/usr/lib/x86_64-linux-gnu/perl/5.26',
archname => 'x86_64-linux-gnu-thread-multi',
cc => 'x86_64-linux-gnu-gcc',
d_readlink => 'define',
d_symlink => 'define',
dlext => 'so',
dlsrc => 'dl_dlopen.xs',
dont_use_nlink => undef,
exe_ext => '',
inc_version_list => '5.26.0 5.26.0/x86_64-linux-gnu-thread-multi',
intsize => '4',
ldlibpthname => 'LD_LIBRARY_PATH',
libpth => '/usr/local/lib /usr/lib/gcc/x86_64-linux-gnu/7/include-fixed /usr/include/x86_64-linux-gnu /usr/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib',
osname => 'linux',
osvers => '4.9.0',
path_sep => ':',
privlibexp => '/usr/share/perl/5.26',
scriptdir => '/usr/bin',
sitearchexp => '/usr/local/lib/x86_64-linux-gnu/perl/5.26.1',
sitelibexp => '/usr/local/share/perl/5.26.1',
so => 'so',
useithreads => 'define',
usevendorprefix => 'define',
version => '5.26.1',
};

12
vendor/LeOS/tools-leos/common/perl-base/Config_git.pl vendored
View File

@ -1,12 +0,0 @@
######################################################################
# WARNING: 'lib/Config_git.pl' is generated by make_patchnum.pl
# DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead
######################################################################
$Config::Git_Data=<<'ENDOFGIT';
git_commit_id=''
git_describe=''
git_branch=''
git_uncommitted_changes=''
git_commit_id_title=''
ENDOFGIT

1526
vendor/LeOS/tools-leos/common/perl-base/Config_heavy.pl vendored
View File

File diff suppressed because one or more lines are too long

697
vendor/LeOS/tools-leos/common/perl-base/Cwd.pm vendored
View File

@ -1,697 +0,0 @@
package Cwd;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
$VERSION = '3.67';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
# sys_cwd may keep the builtin command
# All the functionality of this module may provided by builtins,
# there is no sense to process the rest of the file.
# The best choice may be to have this in BEGIN, but how to return from BEGIN?
if ($^O eq 'os2') {
local $^W = 0;
*cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
*getcwd = \&cwd;
*fastgetcwd = \&cwd;
*fastcwd = \&cwd;
*fast_abs_path = \&sys_abspath if defined &sys_abspath;
*abs_path = \&fast_abs_path;
*realpath = \&fast_abs_path;
*fast_realpath = \&fast_abs_path;
return 1;
}
# Need to look up the feature settings on VMS. The preferred way is to use the
# VMS::Feature module, but that may not be available to dual life modules.
my $use_vms_feature;
BEGIN {
if ($^O eq 'VMS') {
if (eval { local $SIG{__DIE__};
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
require VMS::Feature; }) {
$use_vms_feature = 1;
}
}
}
# Need to look up the UNIX report mode. This may become a dynamic mode
# in the future.
sub _vms_unix_rpt {
my $unix_rpt;
if ($use_vms_feature) {
$unix_rpt = VMS::Feature::current("filename_unix_report");
} else {
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
}
return $unix_rpt;
}
# Need to look up the EFS character set mode. This may become a dynamic
# mode in the future.
sub _vms_efs {
my $efs;
if ($use_vms_feature) {
$efs = VMS::Feature::current("efs_charset");
} else {
my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
$efs = $env_efs =~ /^[ET1]/i;
}
return $efs;
}
# If loading the XS stuff doesn't work, we can fall back to pure perl
if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) {
eval {#eval is questionable since we are handling potential errors like
#"Cwd object version 3.48 does not match bootstrap parameter 3.50
#at lib/DynaLoader.pm line 216." by having this eval
if ( $] >= 5.006 ) {
require XSLoader;
XSLoader::load( __PACKAGE__, $xs_version);
} else {
require DynaLoader;
push @ISA, 'DynaLoader';
__PACKAGE__->bootstrap( $xs_version );
}
};
}
# Big nasty table of function aliases
my %METHOD_MAP =
(
VMS =>
{
cwd => '_vms_cwd',
getcwd => '_vms_cwd',
fastcwd => '_vms_cwd',
fastgetcwd => '_vms_cwd',
abs_path => '_vms_abs_path',
fast_abs_path => '_vms_abs_path',
},
MSWin32 =>
{
# We assume that &_NT_cwd is defined as an XSUB or in the core.
cwd => '_NT_cwd',
getcwd => '_NT_cwd',
fastcwd => '_NT_cwd',
fastgetcwd => '_NT_cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
dos =>
{
cwd => '_dos_cwd',
getcwd => '_dos_cwd',
fastgetcwd => '_dos_cwd',
fastcwd => '_dos_cwd',
abs_path => 'fast_abs_path',
},
# QNX4. QNX6 has a $os of 'nto'.
qnx =>
{
cwd => '_qnx_cwd',
getcwd => '_qnx_cwd',
fastgetcwd => '_qnx_cwd',
fastcwd => '_qnx_cwd',
abs_path => '_qnx_abs_path',
fast_abs_path => '_qnx_abs_path',
},
cygwin =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
epoc =>
{
cwd => '_epoc_cwd',
getcwd => '_epoc_cwd',
fastgetcwd => '_epoc_cwd',
fastcwd => '_epoc_cwd',
abs_path => 'fast_abs_path',
},
MacOS =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
},
amigaos =>
{
getcwd => '_backtick_pwd',
fastgetcwd => '_backtick_pwd',
fastcwd => '_backtick_pwd',
abs_path => 'fast_abs_path',
}
);
$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
# Find the pwd command in the expected locations. We assume these
# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
# so everything works under taint mode.
my $pwd_cmd;
if($^O ne 'MSWin32') {
foreach my $try ('/bin/pwd',
'/usr/bin/pwd',
'/QOpenSys/bin/pwd', # OS/400 PASE.
) {
if( -x $try ) {
$pwd_cmd = $try;
last;
}
}
}
# Android has a built-in pwd. Using $pwd_cmd will DTRT if
# this perl was compiled with -Dd_useshellcmds, which is the
# default for Android, but the block below is needed for the
# miniperl running on the host when cross-compiling, and
# potentially for native builds with -Ud_useshellcmds.
if ($^O =~ /android/) {
# If targetsh is executable, then we're either a full
# perl, or a miniperl for a native build.
if (-x $Config::Config{targetsh}) {
$pwd_cmd = "$Config::Config{targetsh} -c pwd"
}
else {
my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh');
$pwd_cmd = "$sh -c pwd"
}
}
my $found_pwd_cmd = defined($pwd_cmd);
unless ($pwd_cmd) {
# Isn't this wrong? _backtick_pwd() will fail if someone has
# pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
# See [perl #16774]. --jhi
$pwd_cmd = 'pwd';
}
# Lazy-load Carp
sub _carp { require Carp; Carp::carp(@_) }
sub _croak { require Carp; Carp::croak(@_) }
# The 'natural and safe form' for UNIX (pwd may be setuid root)
sub _backtick_pwd {
# Localize %ENV entries in a way that won't create new hash keys.
# Under AmigaOS we don't want to localize as it stops perl from
# finding 'sh' in the PATH.
my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV) if $^O ne "amigaos";
local @ENV{@localize} if @localize;
my $cwd = `$pwd_cmd`;
# Belt-and-suspenders in case someone said "undef $/".
local $/ = "\n";
# `pwd` may fail e.g. if the disk is full
chomp($cwd) if defined $cwd;
$cwd;
}
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().
unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
# The pwd command is not available in some chroot(2)'ed environments
my $sep = $Config::Config{path_sep} || ':';
my $os = $^O; # Protect $^O from tainting
# Try again to find a pwd, this time searching the whole PATH.
if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
my @candidates = split($sep, $ENV{PATH});
while (!$found_pwd_cmd and @candidates) {
my $candidate = shift @candidates;
$found_pwd_cmd = 1 if -x "$candidate/pwd";
}
}
# MacOS has some special magic to make `pwd` work.
if( $os eq 'MacOS' || $found_pwd_cmd )
{
*cwd = \&_backtick_pwd;
}
else {
*cwd = \&getcwd;
}
}
if ($^O eq 'cygwin') {
# We need to make sure cwd() is called with no args, because it's
# got an arg-less prototype and will die if args are present.
local $^W = 0;
my $orig_cwd = \&cwd;
*cwd = sub { &$orig_cwd() }
}
# set a reasonable (and very safe) default for fastgetcwd, in case it
# isn't redefined later (20001212 rspier)
*fastgetcwd = \&cwd;
# A non-XS version of getcwd() - also used to bootstrap the perl build
# process, when miniperl is running and no XS loading happens.
sub _perl_getcwd
{
abs_path('.');
}
# By John Bazik
#
# Usage: $cwd = &fastcwd;
#
# This is a faster version of getcwd. It's also more dangerous because
# you might chdir out of a directory that you can't chdir back into.
sub fastcwd_ {
my($odev, $oino, $cdev, $cino, $tdev, $tino);
my(@path, $path);
local(*DIR);
my($orig_cdev, $orig_cino) = stat('.');
($cdev, $cino) = ($orig_cdev, $orig_cino);
for (;;) {
my $direntry;
($odev, $oino) = ($cdev, $cino);
CORE::chdir('..') || return undef;
($cdev, $cino) = stat('.');
last if $odev == $cdev && $oino == $cino;
opendir(DIR, '.') || return undef;
for (;;) {
$direntry = readdir(DIR);
last unless defined $direntry;
next if $direntry eq '.';
next if $direntry eq '..';
($tdev, $tino) = lstat($direntry);
last unless $tdev != $odev || $tino != $oino;
}
closedir(DIR);
return undef unless defined $direntry; # should never happen
unshift(@path, $direntry);
}
$path = '/' . join('/', @path);
if ($^O eq 'apollo') { $path = "/".$path; }
# At this point $path may be tainted (if tainting) and chdir would fail.
# Untaint it then check that we landed where we started.
$path =~ /^(.*)\z/s # untaint
&& CORE::chdir($1) or return undef;
($cdev, $cino) = stat('.');
die "Unstable directory path, current directory changed unexpectedly"
if $cdev != $orig_cdev || $cino != $orig_cino;
$path;
}
if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
# Keeps track of current working directory in PWD environment var
# Usage:
# use Cwd 'chdir';
# chdir $newdir;
my $chdir_init = 0;
sub chdir_init {
if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
my($dd,$di) = stat('.');
my($pd,$pi) = stat($ENV{'PWD'});
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
$ENV{'PWD'} = cwd();
}
}
else {
my $wd = cwd();
$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
$ENV{'PWD'} = $wd;
}
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
my($pd,$pi) = stat($2);
my($dd,$di) = stat($1);
if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
$ENV{'PWD'}="$2$3";
}
}
$chdir_init = 1;
}
sub chdir {
my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
if ($^O eq "cygwin") {
$newdir =~ s|\A///+|//|;
$newdir =~ s|(?<=[^/])//+|/|g;
}
elsif ($^O ne 'MSWin32') {
$newdir =~ s|///*|/|g;
}
chdir_init() unless $chdir_init;
my $newpwd;
if ($^O eq 'MSWin32') {
# get the full path name *before* the chdir()
$newpwd = Win32::GetFullPathName($newdir);
}
return 0 unless CORE::chdir $newdir;
if ($^O eq 'VMS') {
return $ENV{'PWD'} = $ENV{'DEFAULT'}
}
elsif ($^O eq 'MacOS') {
return $ENV{'PWD'} = cwd();
}
elsif ($^O eq 'MSWin32') {
$ENV{'PWD'} = $newpwd;
return 1;
}
if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
$ENV{'PWD'} = cwd();
} elsif ($newdir =~ m#^/#s) {
$ENV{'PWD'} = $newdir;
} else {
my @curdir = split(m#/#,$ENV{'PWD'});
@curdir = ('') unless @curdir;
my $component;
foreach $component (split(m#/#, $newdir)) {
next if $component eq '.';
pop(@curdir),next if $component eq '..';
push(@curdir,$component);
}
$ENV{'PWD'} = join('/',@curdir) || '/';
}
1;
}
sub _perl_abs_path
{
my $start = @_ ? shift : '.';
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat( $start ))
{
_carp("stat($start): $!");
return '';
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
# NOTE that this routine assumes that '/' is the only directory separator.
my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
or return cwd() . '/' . $start;
# Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
if (-l $start) {
my $link_target = readlink($start);
die "Can't resolve link $start: $!" unless defined $link_target;
require File::Spec;
$link_target = $dir . '/' . $link_target
unless File::Spec->file_name_is_absolute($link_target);
return abs_path($link_target);
}
return $dir ? abs_path($dir) . "/$file" : "/$file";
}
$cwd = '';
$dotdots = $start;
do
{
$dotdots .= '/..';
@pst = @cst;
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
# probably a permissions issue. Try the native command.
require File::Spec;
return File::Spec->rel2abs( $start, _backtick_pwd() );
}
unless (@cst = stat($dotdots))
{
_carp("stat($dotdots): $!");
closedir(PARENT);
return '';
}
if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
{
$dir = undef;
}
else
{
do
{
unless (defined ($dir = readdir(PARENT)))
{
_carp("readdir($dotdots): $!");
closedir(PARENT);
return '';
}
$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
}
while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
$tst[1] != $pst[1]);
}
$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
closedir(PARENT);
} while (defined $dir);
chop($cwd) unless $cwd eq '/'; # drop the trailing /
$cwd;
}
my $Curdir;
sub fast_abs_path {
local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
my $cwd = getcwd();
require File::Spec;
my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
# Detaint else we'll explode in taint mode. This is safe because
# we're not doing anything dangerous with it.
($path) = $path =~ /(.*)/s;
($cwd) = $cwd =~ /(.*)/s;
unless (-e $path) {
_croak("$path: No such file or directory");
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
my ($vol, $dir, $file) = File::Spec->splitpath($path);
return File::Spec->catfile($cwd, $path) unless length $dir;
if (-l $path) {
my $link_target = readlink($path);
die "Can't resolve link $path: $!" unless defined $link_target;
$link_target = File::Spec->catpath($vol, $dir, $link_target)
unless File::Spec->file_name_is_absolute($link_target);
return fast_abs_path($link_target);
}
return $dir eq File::Spec->rootdir
? File::Spec->catpath($vol, $dir, $file)
: fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
}
if (!CORE::chdir($path)) {
_croak("Cannot chdir to $path: $!");
}
my $realpath = getcwd();
if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
_croak("Cannot chdir back to $cwd: $!");
}
$realpath;
}
# added function alias to follow principle of least surprise
# based on previous aliasing. --tchrist 27-Jan-00
*fast_realpath = \&fast_abs_path;
# --- PORTING SECTION ---
# VMS: $ENV{'DEFAULT'} points to default directory at all times
# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
# in the process logical name table as the default device and directory
# seen by Perl. This may not be the same as the default device
# and directory seen by DCL after Perl exits, since the effects
# the CRTL chdir() function persist only until Perl exits.
sub _vms_cwd {
return $ENV{'DEFAULT'};
}
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
my $path = shift;
my $efs = _vms_efs;
my $unix_rpt = _vms_unix_rpt;
if (defined &VMS::Filespec::vmsrealpath) {
my $path_unix = 0;
my $path_vms = 0;
$path_unix = 1 if ($path =~ m#(?<=\^)/#);
$path_unix = 1 if ($path =~ /^\.\.?$/);
$path_vms = 1 if ($path =~ m#[\[<\]]#);
$path_vms = 1 if ($path =~ /^--?$/);
my $unix_mode = $path_unix;
if ($efs) {
# In case of a tie, the Unix report mode decides.
if ($path_vms == $path_unix) {
$unix_mode = $unix_rpt;
} else {
$unix_mode = 0 if $path_vms;
}
}
if ($unix_mode) {
# Unix format
return VMS::Filespec::unixrealpath($path);
}
# VMS format
my $new_path = VMS::Filespec::vmsrealpath($path);
# Perl expects directories to be in directory format
$new_path = VMS::Filespec::pathify($new_path) if -d $path;
return $new_path;
}
# Fallback to older algorithm if correct ones are not
# available.
if (-l $path) {
my $link_target = readlink($path);
die "Can't resolve link $path: $!" unless defined $link_target;
return _vms_abs_path($link_target);
}
# may need to turn foo.dir into [.foo]
my $pathified = VMS::Filespec::pathify($path);
$path = $pathified if defined $pathified;
return VMS::Filespec::rmsexpand($path);
}
sub _os2_cwd {
my $pwd = `cmd /c cd`;
chomp $pwd;
$pwd =~ s:\\:/:g ;
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _win32_cwd_simple {
my $pwd = `cd`;
chomp $pwd;
$pwd =~ s:\\:/:g ;
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _win32_cwd {
my $pwd;
$pwd = Win32::GetCwd();
$pwd =~ s:\\:/:g ;
$ENV{'PWD'} = $pwd;
return $pwd;
}
*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
sub _dos_cwd {
my $pwd;
if (!defined &Dos::GetCwd) {
chomp($pwd = `command /c cd`);
$pwd =~ s:\\:/:g ;
} else {
$pwd = Dos::GetCwd();
}
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _qnx_cwd {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
my $pwd = `/usr/bin/fullpath -t`;
chomp $pwd;
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _qnx_abs_path {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
my $path = @_ ? shift : '.';
local *REALPATH;
defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
die "Can't open /usr/bin/fullpath: $!";
my $realpath = <REALPATH>;
close REALPATH;
chomp $realpath;
return $realpath;
}
sub _epoc_cwd {
return $ENV{'PWD'} = EPOC::getcwd();
}
# Now that all the base-level functions are set up, alias the
# user-level functions to the right places
if (exists $METHOD_MAP{$^O}) {
my $map = $METHOD_MAP{$^O};
foreach my $name (keys %$map) {
local $^W = 0; # assignments trigger 'subroutine redefined' warning
no strict 'refs';
*{$name} = \&{$map->{$name}};
}
}
# In case the XS version doesn't load.
*abs_path = \&_perl_abs_path unless defined &abs_path;
*getcwd = \&_perl_getcwd unless defined &getcwd;
# added function alias for those of us more
# used to the libc function. --tchrist 27-Jan-00
*realpath = \&abs_path;
1;
__END__

314
vendor/LeOS/tools-leos/common/perl-base/DynaLoader.pm vendored
View File

@ -1,314 +0,0 @@
# Generated from DynaLoader_pm.PL, this file is unique for every OS
package DynaLoader;
# And Gandalf said: 'Many folk like to know beforehand what is to
# be set on the table; but those who have laboured to prepare the
# feast like to keep their secret; for wonder makes the words of
# praise louder.'
# (Quote from Tolkien suggested by Anno Siegel.)
#
# See pod text at end of file for documentation.
# See also ext/DynaLoader/README in source tree for other information.
#
# Tim.Bunce@ig.co.uk, August 1994
BEGIN {
$VERSION = '1.42';
}
use Config;
# enable debug/trace messages from DynaLoader perl code
$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
#
# Flags to alter dl_load_file behaviour. Assigned bits:
# 0x01 make symbols available for linking later dl_load_file's.
# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
# (ignored under VMS; effect is built-in to image linking)
# (ignored under Android; the linker always uses RTLD_LOCAL)
#
# This is called as a class method $module->dl_load_flags. The
# definition here will be inherited and result on "default" loading
# behaviour unless a sub-class of DynaLoader defines its own version.
#
sub dl_load_flags { 0x00 }
($dl_dlext, $dl_so, $dlsrc) = @Config::Config{qw(dlext so dlsrc)};
$do_expand = 0;
@dl_require_symbols = (); # names of symbols we need
@dl_library_path = (); # path to look for files
#XSLoader.pm may have added elements before we were required
#@dl_shared_objects = (); # shared objects for symbols we have
#@dl_librefs = (); # things we have loaded
#@dl_modules = (); # Modules we have loaded
# Initialise @dl_library_path with the 'standard' library path
# for this platform as determined by Configure.
push(@dl_library_path, split(' ', $Config::Config{libpth}));
my $ldlibpthname = $Config::Config{ldlibpthname};
my $ldlibpthname_defined = defined $Config::Config{ldlibpthname};
my $pthsep = $Config::Config{path_sep};
# Add to @dl_library_path any extra directories we can gather from environment
# during runtime.
if ($ldlibpthname_defined &&
exists $ENV{$ldlibpthname}) {
push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
}
# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
if ($ldlibpthname_defined &&
$ldlibpthname ne 'LD_LIBRARY_PATH' &&
exists $ENV{LD_LIBRARY_PATH}) {
push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
}
# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
!defined(&dl_error);
if ($dl_debug) {
print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
print STDERR "DynaLoader not linked into this perl\n"
unless defined(&boot_DynaLoader);
}
1; # End of main code
sub croak { require Carp; Carp::croak(@_) }
sub bootstrap_inherit {
my $module = $_[0];
local *isa = *{"$module\::ISA"};
local @isa = (@isa, 'DynaLoader');
# Cannot goto due to delocalization. Will report errors on a wrong line?
bootstrap(@_);
}
sub bootstrap {
# use local vars to enable $module.bs script to edit values
local(@args) = @_;
local($module) = $args[0];
local(@dirs, $file);
unless ($module) {
require Carp;
Carp::confess("Usage: DynaLoader::bootstrap(module)");
}
# A common error on platforms which don't support dynamic loading.
# Since it's fatal and potentially confusing we give a detailed message.
croak("Can't load module $module, dynamic loading not available in this perl.\n".
" (You may need to build a new perl executable which either supports\n".
" dynamic loading or has the $module module statically linked into it.)\n")
unless defined(&dl_load_file);
my @modparts = split(/::/,$module);
my $modfname = $modparts[-1];
my $modfname_orig = $modfname; # For .bs file search
# Some systems have restrictions on files names for DLL's etc.
# mod2fname returns appropriate file base name (typically truncated)
# It may also edit @modparts if required.
$modfname = &mod2fname(\@modparts) if defined &mod2fname;
my $modpname = join('/',@modparts);
print STDERR "DynaLoader::bootstrap for $module ",
"(auto/$modpname/$modfname.$dl_dlext)\n"
if $dl_debug;
my $dir;
foreach (@INC) {
$dir = "$_/auto/$modpname";
next unless -d $dir; # skip over uninteresting directories
# check for common cases to avoid autoload of dl_findfile
my $try = "$dir/$modfname.$dl_dlext";
last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try);
# no luck here, save dir for possible later dl_findfile search
push @dirs, $dir;
}
# last resort, let dl_findfile have a go in all known locations
$file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
unless $file; # wording similar to error from 'require'
my $bootname = "boot_$module";
$bootname =~ s/\W/_/g;
@dl_require_symbols = ($bootname);
# Execute optional '.bootstrap' perl script for this module.
# The .bs file can be used to configure @dl_resolve_using etc to
# match the needs of the individual module on this architecture.
# N.B. The .bs file does not following the naming convention used
# by mod2fname.
my $bs = "$dir/$modfname_orig";
$bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
if (-s $bs) { # only read file if it's not empty
print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
eval { local @INC = ('.'); do $bs; };
warn "$bs: $@\n" if $@;
}
my $boot_symbol_ref;
# Many dynamic extension loading problems will appear to come from
# this section of code: XYZ failed at line 123 of DynaLoader.pm.
# Often these errors are actually occurring in the initialisation
# C code of the extension XS file. Perl reports the error as being
# in this perl code simply because this was the last perl code
# it executed.
my $flags = $module->dl_load_flags;
my $libref = dl_load_file($file, $flags) or
croak("Can't load '$file' for module $module: ".dl_error());
push(@dl_librefs,$libref); # record loaded object
$boot_symbol_ref = dl_find_symbol($libref, $bootname) or
croak("Can't find '$bootname' symbol in $file\n");
push(@dl_modules, $module); # record loaded module
boot:
my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
# See comment block above
push(@dl_shared_objects, $file); # record files loaded
&$xs(@args);
}
sub dl_findfile {
# This function does not automatically consider the architecture
# or the perl library auto directories.
my (@args) = @_;
my (@dirs, $dir); # which directories to search
my (@found); # full paths to real files we have found
#my $dl_ext= 'so'; # $Config::Config{'dlext'} suffix for perl extensions
#my $dl_so = 'so'; # $Config::Config{'so'} suffix for shared libraries
print STDERR "dl_findfile(@args)\n" if $dl_debug;
# accumulate directories but process files as they appear
arg: foreach(@args) {
# Special fast case: full filepath requires no search
if (m:/: && -f $_) {
push(@found,$_);
last arg unless wantarray;
next;
}
# Deal with directories first:
# Using a -L prefix is the preferred option (faster and more robust)
if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }
# Otherwise we try to try to spot directories by a heuristic
# (this is a more complicated issue than it first appears)
if (m:/: && -d $_) { push(@dirs, $_); next; }
# Only files should get this far...
my(@names, $name); # what filenames to look for
if (m:-l: ) { # convert -lname to appropriate library name
s/-l//;
push(@names,"lib$_.$dl_so");
push(@names,"lib$_.a");
} else { # Umm, a bare name. Try various alternatives:
# these should be ordered with the most likely first
push(@names,"$_.$dl_dlext") unless m/\.$dl_dlext$/o;
push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
push(@names,"lib$_.$dl_so") unless m:/:;
push(@names, $_);
}
my $dirsep = '/';
foreach $dir (@dirs, @dl_library_path) {
next unless -d $dir;
foreach $name (@names) {
my($file) = "$dir$dirsep$name";
print STDERR " checking in $dir for $name\n" if $dl_debug;
$file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
#$file = _check_file($file);
if ($file) {
push(@found, $file);
next arg; # no need to look any further
}
}
}
}
if ($dl_debug) {
foreach(@dirs) {
print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
}
print STDERR "dl_findfile found: @found\n";
}
return $found[0] unless wantarray;
@found;
}
sub dl_expandspec {
my($spec) = @_;
# Optional function invoked if DynaLoader.pm sets $do_expand.
# Most systems do not require or use this function.
# Some systems may implement it in the dl_*.xs file in which case
# this Perl version should be excluded at build time.
# This function is designed to deal with systems which treat some
# 'filenames' in a special way. For example VMS 'Logical Names'
# (something like unix environment variables - but different).
# This function should recognise such names and expand them into
# full file paths.
# Must return undef if $spec is invalid or file does not exist.
my $file = $spec; # default output to input
return undef unless -f $file;
print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
$file;
}
sub dl_find_symbol_anywhere
{
my $sym = shift;
my $libref;
foreach $libref (@dl_librefs) {
my $symref = dl_find_symbol($libref,$sym,1);
return $symref if $symref;
}
return undef;
}
__END__

229
vendor/LeOS/tools-leos/common/perl-base/Errno.pm vendored
View File

@ -1,229 +0,0 @@
# -*- buffer-read-only: t -*-
#
# This file is auto-generated by ext/Errno/Errno_pm.PL.
# ***ANY*** changes here will be lost.
#
package Errno;
require Exporter;
use strict;
our $VERSION = "1.28";
$VERSION = eval $VERSION;
our @ISA = 'Exporter';
my %err;
BEGIN {
%err = (
EPERM => 1,
ENOENT => 2,
ESRCH => 3,
EINTR => 4,
EIO => 5,
ENXIO => 6,
E2BIG => 7,
ENOEXEC => 8,
EBADF => 9,
ECHILD => 10,
EAGAIN => 11,
EWOULDBLOCK => 11,
ENOMEM => 12,
EACCES => 13,
EFAULT => 14,
ENOTBLK => 15,
EBUSY => 16,
EEXIST => 17,
EXDEV => 18,
ENODEV => 19,
ENOTDIR => 20,
EISDIR => 21,
EINVAL => 22,
ENFILE => 23,
EMFILE => 24,
ENOTTY => 25,
ETXTBSY => 26,
EFBIG => 27,
ENOSPC => 28,
ESPIPE => 29,
EROFS => 30,
EMLINK => 31,
EPIPE => 32,
EDOM => 33,
ERANGE => 34,
EDEADLK => 35,
EDEADLOCK => 35,
ENAMETOOLONG => 36,
ENOLCK => 37,
ENOSYS => 38,
ENOTEMPTY => 39,
ELOOP => 40,
ENOMSG => 42,
EIDRM => 43,
ECHRNG => 44,
EL2NSYNC => 45,
EL3HLT => 46,
EL3RST => 47,
ELNRNG => 48,
EUNATCH => 49,
ENOCSI => 50,
EL2HLT => 51,
EBADE => 52,
EBADR => 53,
EXFULL => 54,
ENOANO => 55,
EBADRQC => 56,
EBADSLT => 57,
EBFONT => 59,
ENOSTR => 60,
ENODATA => 61,
ETIME => 62,
ENOSR => 63,
ENONET => 64,
ENOPKG => 65,
EREMOTE => 66,
ENOLINK => 67,
EADV => 68,
ESRMNT => 69,
ECOMM => 70,
EPROTO => 71,
EMULTIHOP => 72,
EDOTDOT => 73,
EBADMSG => 74,
EOVERFLOW => 75,
ENOTUNIQ => 76,
EBADFD => 77,
EREMCHG => 78,
ELIBACC => 79,
ELIBBAD => 80,
ELIBSCN => 81,
ELIBMAX => 82,
ELIBEXEC => 83,
EILSEQ => 84,
ERESTART => 85,
ESTRPIPE => 86,
EUSERS => 87,
ENOTSOCK => 88,
EDESTADDRREQ => 89,
EMSGSIZE => 90,
EPROTOTYPE => 91,
ENOPROTOOPT => 92,
EPROTONOSUPPORT => 93,
ESOCKTNOSUPPORT => 94,
ENOTSUP => 95,
EOPNOTSUPP => 95,
EPFNOSUPPORT => 96,
EAFNOSUPPORT => 97,
EADDRINUSE => 98,
EADDRNOTAVAIL => 99,
ENETDOWN => 100,
ENETUNREACH => 101,
ENETRESET => 102,
ECONNABORTED => 103,
ECONNRESET => 104,
ENOBUFS => 105,
EISCONN => 106,
ENOTCONN => 107,
ESHUTDOWN => 108,
ETOOMANYREFS => 109,
ETIMEDOUT => 110,
ECONNREFUSED => 111,
EHOSTDOWN => 112,
EHOSTUNREACH => 113,
EALREADY => 114,
EINPROGRESS => 115,
ESTALE => 116,
EUCLEAN => 117,
ENOTNAM => 118,
ENAVAIL => 119,
EISNAM => 120,
EREMOTEIO => 121,
EDQUOT => 122,
ENOMEDIUM => 123,
EMEDIUMTYPE => 124,
ECANCELED => 125,
ENOKEY => 126,
EKEYEXPIRED => 127,
EKEYREVOKED => 128,
EKEYREJECTED => 129,
EOWNERDEAD => 130,
ENOTRECOVERABLE => 131,
ERFKILL => 132,
EHWPOISON => 133,
);
# Generate proxy constant subroutines for all the values.
# Well, almost all the values. Unfortunately we can't assume that at this
# point that our symbol table is empty, as code such as if the parser has
# seen code such as C<exists &Errno::EINVAL>, it will have created the
# typeglob.
# Doing this before defining @EXPORT_OK etc means that even if a platform is
# crazy enough to define EXPORT_OK as an error constant, everything will
# still work, because the parser will upgrade the PCS to a real typeglob.
# We rely on the subroutine definitions below to update the internal caches.
# Don't use %each, as we don't want a copy of the value.
foreach my $name (keys %err) {
if ($Errno::{$name}) {
# We expect this to be reached fairly rarely, so take an approach
# which uses the least compile time effort in the common case:
eval "sub $name() { $err{$name} }; 1" or die $@;
} else {
$Errno::{$name} = \$err{$name};
}
}
}
our @EXPORT_OK = keys %err;
our %EXPORT_TAGS = (
POSIX => [qw(
E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY
EBADF EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK
EDESTADDRREQ EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH
EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS
ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK
ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
EPFNOSUPPORT EPIPE EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART
EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT
ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV
)],
);
sub TIEHASH { bless \%err }
sub FETCH {
my (undef, $errname) = @_;
return "" unless exists $err{$errname};
my $errno = $err{$errname};
return $errno == $! ? $errno : 0;
}
sub STORE {
require Carp;
Carp::confess("ERRNO hash is read only!");
}
# This is the true return value
*CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
sub NEXTKEY {
each %err;
}
sub FIRSTKEY {
my $s = scalar keys %err; # initialize iterator
each %err;
}
sub EXISTS {
my (undef, $errname) = @_;
exists $err{$errname};
}
sub _tie_it {
tie %{$_[0]}, __PACKAGE__;
}
__END__
# ex: set ro:

98
vendor/LeOS/tools-leos/common/perl-base/Exporter.pm vendored
View File

@ -1,98 +0,0 @@
package Exporter;
require 5.006;
# Be lean.
#use strict;
#no strict 'refs';
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
our $VERSION = '5.72';
our (%Cache);
sub as_heavy {
require Exporter::Heavy;
# Unfortunately, this does not work if the caller is aliased as *name = \&foo
# Thus the need to create a lot of identical subroutines
my $c = (caller(1))[3];
$c =~ s/.*:://;
\&{"Exporter::Heavy::heavy_$c"};
}
sub export {
goto &{as_heavy()};
}
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
*{$callpkg."::import"} = \&import;
return;
}
# We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
my $exports = \@{"$pkg\::EXPORT"};
# But, avoid creating things if they don't exist, which saves a couple of
# hundred bytes per package processed.
my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"};
return export $pkg, $callpkg, @_
if $Verbose or $Debug or $fail && @$fail > 1;
my $export_cache = ($Cache{$pkg} ||= {});
my $args = @_ or @_ = @$exports;
if ($args and not %$export_cache) {
s/^&//, $export_cache->{$_} = 1
foreach (@$exports, @{"$pkg\::EXPORT_OK"});
}
my $heavy;
# Try very hard not to use {} and hence have to enter scope on the foreach
# We bomb out of the loop with last as soon as heavy is set.
if ($args or $fail) {
($heavy = (/\W/ or $args and not exists $export_cache->{$_}
or $fail and @$fail and $_ eq $fail->[0])) and last
foreach (@_);
} else {
($heavy = /\W/) and last
foreach (@_);
}
return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
local $SIG{__WARN__} =
sub {require Carp; &Carp::carp} if not $SIG{__WARN__};
# shortcut for the common case of no type character
*{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
}
# Default methods
sub export_fail {
my $self = shift;
@_;
}
# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
# *name = \&foo. Thus the need to create a lot of identical subroutines
# Otherwise we could have aliased them to export().
sub export_to_level {
goto &{as_heavy()};
}
sub export_tags {
goto &{as_heavy()};
}
sub export_ok_tags {
goto &{as_heavy()};
}
sub require_version {
goto &{as_heavy()};
}
1;
__END__

239
vendor/LeOS/tools-leos/common/perl-base/Exporter/Heavy.pm vendored
View File

@ -1,239 +0,0 @@
package Exporter::Heavy;
use strict;
no strict 'refs';
# On one line so MakeMaker will see it.
require Exporter; our $VERSION = $Exporter::VERSION;
#
# We go to a lot of trouble not to 'require Carp' at file scope,
# because Carp requires Exporter, and something has to give.
#
sub _rebuild_cache {
my ($pkg, $exports, $cache) = @_;
s/^&// foreach @$exports;
@{$cache}{@$exports} = (1) x @$exports;
my $ok = \@{"${pkg}::EXPORT_OK"};
if (@$ok) {
s/^&// foreach @$ok;
@{$cache}{@$ok} = (1) x @$ok;
}
}
sub heavy_export {
# Save the old __WARN__ handler in case it was defined
my $oldwarn = $SIG{__WARN__};
# First make import warnings look like they're coming from the "use".
local $SIG{__WARN__} = sub {
# restore it back so proper stacking occurs
local $SIG{__WARN__} = $oldwarn;
my $text = shift;
if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::carp($text);
}
else {
warn $text;
}
};
local $SIG{__DIE__} = sub {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
};
my($pkg, $callpkg, @imports) = @_;
my($type, $sym, $cache_is_current, $oops);
my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
$Exporter::Cache{$pkg} ||= {});
if (@imports) {
if (!%$export_cache) {
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (grep m{^[/!:]}, @imports) {
my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
my $tagdata;
my %imports;
my($remove, $spec, @names, @allexports);
# negated first item implies starting with default set:
unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
foreach $spec (@imports){
$remove = $spec =~ s/^!//;
if ($spec =~ s/^://){
if ($spec eq 'DEFAULT'){
@names = @$exports;
}
elsif ($tagdata = $tagsref->{$spec}) {
@names = @$tagdata;
}
else {
warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
++$oops;
next;
}
}
elsif ($spec =~ m:^/(.*)/$:){
my $patn = $1;
@allexports = keys %$export_cache unless @allexports; # only do keys once
@names = grep(/$patn/, @allexports); # not anchored by default
}
else {
@names = ($spec); # is a normal symbol name
}
warn "Import ".($remove ? "del":"add").": @names "
if $Exporter::Verbose;
if ($remove) {
foreach $sym (@names) { delete $imports{$sym} }
}
else {
@imports{@names} = (1) x @names;
}
}
@imports = keys %imports;
}
my @carp;
foreach $sym (@imports) {
if (!$export_cache->{$sym}) {
if ($sym =~ m/^\d/) {
$pkg->VERSION($sym); # inherit from UNIVERSAL
# If the version number was the only thing specified
# then we should act as if nothing was specified:
if (@imports == 1) {
@imports = @$exports;
last;
}
# We need a way to emulate 'use Foo ()' but still
# allow an easy version check: "use Foo 1.23, ''";
if (@imports == 2 and !$imports[1]) {
@imports = ();
last;
}
} elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
# Last chance - see if they've updated EXPORT_OK since we
# cached it.
unless ($cache_is_current) {
%$export_cache = ();
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (!$export_cache->{$sym}) {
# accumulate the non-exports
push @carp,
qq["$sym" is not exported by the $pkg module\n];
$oops++;
}
}
}
}
if ($oops) {
require Carp;
Carp::croak("@{carp}Can't continue after import errors");
}
}
else {
@imports = @$exports;
}
my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
$Exporter::FailCache{$pkg} ||= {});
if (@$fail) {
if (!%$fail_cache) {
# Build cache of symbols. Optimise the lookup by adding
# barewords twice... both with and without a leading &.
# (Technique could be applied to $export_cache at cost of memory)
my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
@{$fail_cache}{@expanded} = (1) x @expanded;
}
my @failed;
foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
if (@failed) {
@failed = $pkg->export_fail(@failed);
foreach $sym (@failed) {
require Carp;
Carp::carp(qq["$sym" is not implemented by the $pkg module ],
"on this architecture");
}
if (@failed) {
require Carp;
Carp::croak("Can't continue after import errors");
}
}
}
warn "Importing into $callpkg from $pkg: ",
join(", ",sort @imports) if $Exporter::Verbose;
foreach $sym (@imports) {
# shortcut for the common case of no type character
(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
unless $sym =~ s/^(\W)//;
$type = $1;
no warnings 'once';
*{"${callpkg}::$sym"} =
$type eq '&' ? \&{"${pkg}::$sym"} :
$type eq '$' ? \${"${pkg}::$sym"} :
$type eq '@' ? \@{"${pkg}::$sym"} :
$type eq '%' ? \%{"${pkg}::$sym"} :
$type eq '*' ? *{"${pkg}::$sym"} :
do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
}
}
sub heavy_export_to_level
{
my $pkg = shift;
my $level = shift;
(undef) = shift; # XXX redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
# Utility functions
sub _push_tags {
my($pkg, $var, $syms) = @_;
my @nontag = ();
my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
push(@{"${pkg}::$var"},
map { $export_tags->{$_} ? @{$export_tags->{$_}}
: scalar(push(@nontag,$_),$_) }
(@$syms) ? @$syms : keys %$export_tags);
if (@nontag and $^W) {
# This may change to a die one day
require Carp;
Carp::carp(join(", ", @nontag)." are not tags of $pkg");
}
}
sub heavy_require_version {
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
return ${pkg}->VERSION($wanted);
}
sub heavy_export_tags {
_push_tags((caller)[0], "EXPORT", \@_);
}
sub heavy_export_ok_tags {
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
1;

138
vendor/LeOS/tools-leos/common/perl-base/Fcntl.pm vendored
View File

@ -1,138 +0,0 @@
package Fcntl;
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
require Exporter;
require XSLoader;
@ISA = qw(Exporter);
$VERSION = '1.13';
XSLoader::load();
# Named groups of exports
%EXPORT_TAGS = (
'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)],
'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE
FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)],
'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)],
'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT
_S_IFMT S_IFREG S_IFDIR S_IFLNK
S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT
S_IRUSR S_IWUSR S_IXUSR S_IRWXU
S_IRGRP S_IWGRP S_IXGRP S_IRWXG
S_IROTH S_IWOTH S_IXOTH S_IRWXO
S_IREAD S_IWRITE S_IEXEC
S_ISREG S_ISDIR S_ISLNK S_ISSOCK
S_ISBLK S_ISCHR S_ISFIFO
S_ISWHT S_ISENFMT
S_IFMT S_IMODE
)],
);
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT =
qw(
FD_CLOEXEC
F_ALLOCSP
F_ALLOCSP64
F_COMPAT
F_DUP2FD
F_DUPFD
F_EXLCK
F_FREESP
F_FREESP64
F_FSYNC
F_FSYNC64
F_GETFD
F_GETFL
F_GETLK
F_GETLK64
F_GETOWN
F_NODNY
F_POSIX
F_RDACC
F_RDDNY
F_RDLCK
F_RWACC
F_RWDNY
F_SETFD
F_SETFL
F_SETLK
F_SETLK64
F_SETLKW
F_SETLKW64
F_SETOWN
F_SHARE
F_SHLCK
F_UNLCK
F_UNSHARE
F_WRACC
F_WRDNY
F_WRLCK
O_ACCMODE
O_ALIAS
O_APPEND
O_ASYNC
O_BINARY
O_CREAT
O_DEFER
O_DIRECT
O_DIRECTORY
O_DSYNC
O_EXCL
O_EXLOCK
O_LARGEFILE
O_NDELAY
O_NOCTTY
O_NOFOLLOW
O_NOINHERIT
O_NONBLOCK
O_RANDOM
O_RAW
O_RDONLY
O_RDWR
O_RSRC
O_RSYNC
O_SEQUENTIAL
O_SHLOCK
O_SYNC
O_TEMPORARY
O_TEXT
O_TRUNC
O_WRONLY
);
# Other items we are prepared to export if requested
@EXPORT_OK = (qw(
DN_ACCESS
DN_ATTRIB
DN_CREATE
DN_DELETE
DN_MODIFY
DN_MULTISHOT
DN_RENAME
F_GETLEASE
F_GETPIPE_SZ
F_GETSIG
F_NOTIFY
F_SETLEASE
F_SETPIPE_SZ
F_SETSIG
LOCK_MAND
LOCK_READ
LOCK_RW
LOCK_WRITE
O_ALT_IO
O_EVTONLY
O_IGNORE_CTTY
O_NOATIME
O_NOLINK
O_NOSIGPIPE
O_NOTRANS
O_SYMLINK
O_TTY_INIT
), map {@{$_}} values %EXPORT_TAGS);
1;

210
vendor/LeOS/tools-leos/common/perl-base/File/Basename.pm vendored
View File

@ -1,210 +0,0 @@
package File::Basename;
# File::Basename is used during the Perl build, when the re extension may
# not be available, but we only actually need it if running under tainting.
BEGIN {
if (${^TAINT}) {
require re;
re->import('taint');
}
}
use strict;
use 5.006;
use warnings;
our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
$VERSION = "2.85";
fileparse_set_fstype($^O);
sub fileparse {
my($fullname,@suffices) = @_;
unless (defined $fullname) {
require Carp;
Carp::croak("fileparse(): need a valid pathname");
}
my $orig_type = '';
my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
my($taint) = substr($fullname,0,0); # Is $fullname tainted?
if ($type eq "VMS" and $fullname =~ m{/} ) {
# We're doing Unix emulation
$orig_type = $type;
$type = 'Unix';
}
my($dirpath, $basename);
if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
$dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
}
elsif ($type eq "OS2") {
($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
$dirpath = './' unless $dirpath; # Can't be 0
$dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
}
elsif ($type eq "MacOS") {
($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
$dirpath = ':' unless $dirpath;
}
elsif ($type eq "AmigaOS") {
($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
$dirpath = './' unless $dirpath;
}
elsif ($type eq 'VMS' ) {
($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
$dirpath ||= ''; # should always be defined
}
else { # Default to Unix semantics.
($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
# dev:[000000] is top of VMS tree, similar to Unix '/'
# so strip it off and treat the rest as "normal"
my $devspec = $1;
my $remainder = $3;
($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
$dirpath ||= ''; # should always be defined
$dirpath = $devspec.$dirpath;
}
$dirpath = './' unless $dirpath;
}
my $tail = '';
my $suffix = '';
if (@suffices) {
foreach $suffix (@suffices) {
my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
if ($basename =~ s/$pat//s) {
$taint .= substr($suffix,0,0);
$tail = $1 . $tail;
}
}
}
# Ensure taint is propagated from the path to its pieces.
$tail .= $taint;
wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
: ($basename .= $taint);
}
sub basename {
my($path) = shift;
# From BSD basename(1)
# The basename utility deletes any prefix ending with the last slash '/'
# character present in string (after first stripping trailing slashes)
_strip_trailing_sep($path);
my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
# From BSD basename(1)
# The suffix is not stripped if it is identical to the remaining
# characters in string.
if( length $suffix and !length $basename ) {
$basename = $suffix;
}
# Ensure that basename '/' == '/'
if( !length $basename ) {
$basename = $dirname;
}
return $basename;
}
sub dirname {
my $path = shift;
my($type) = $Fileparse_fstype;
if( $type eq 'VMS' and $path =~ m{/} ) {
# Parse as Unix
local($File::Basename::Fileparse_fstype) = '';
return dirname($path);
}
my($basename, $dirname) = fileparse($path);
if ($type eq 'VMS') {
$dirname ||= $ENV{DEFAULT};
}
elsif ($type eq 'MacOS') {
if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
_strip_trailing_sep($dirname);
($basename,$dirname) = fileparse $dirname;
}
$dirname .= ":" unless $dirname =~ /:\z/;
}
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
_strip_trailing_sep($dirname);
unless( length($basename) ) {
($basename,$dirname) = fileparse $dirname;
_strip_trailing_sep($dirname);
}
}
elsif ($type eq 'AmigaOS') {
if ( $dirname =~ /:\z/) { return $dirname }
chop $dirname;
$dirname =~ s{[^:/]+\z}{} unless length($basename);
}
else {
_strip_trailing_sep($dirname);
unless( length($basename) ) {
($basename,$dirname) = fileparse $dirname;
_strip_trailing_sep($dirname);
}
}
$dirname;
}
# Strip the trailing path separator.
sub _strip_trailing_sep {
my $type = $Fileparse_fstype;
if ($type eq 'MacOS') {
$_[0] =~ s/([^:]):\z/$1/s;
}
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
$_[0] =~ s/([^:])[\\\/]*\z/$1/;
}
else {
$_[0] =~ s{(.)/*\z}{$1}s;
}
}
BEGIN {
my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
my @Types = (@Ignore_Case, qw(Unix));
sub fileparse_set_fstype {
my $old = $Fileparse_fstype;
if (@_) {
my $new_type = shift;
$Fileparse_fstype = 'Unix'; # default
foreach my $type (@Types) {
$Fileparse_fstype = $type if $new_type =~ /^$type/i;
}
$Fileparse_igncase =
(grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
}
return $old;
}
}
1;

90
vendor/LeOS/tools-leos/common/perl-base/File/Glob.pm vendored
View File

@ -1,90 +0,0 @@
package File::Glob;
use strict;
our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS);
require XSLoader;
@ISA = qw(Exporter);
# NOTE: The glob() export is only here for compatibility with 5.6.0.
# csh_glob() should not be used directly, unless you know what you're doing.
%EXPORT_TAGS = (
'glob' => [ qw(
GLOB_ABEND
GLOB_ALPHASORT
GLOB_ALTDIRFUNC
GLOB_BRACE
GLOB_CSH
GLOB_ERR
GLOB_ERROR
GLOB_LIMIT
GLOB_MARK
GLOB_NOCASE
GLOB_NOCHECK
GLOB_NOMAGIC
GLOB_NOSORT
GLOB_NOSPACE
GLOB_QUOTE
GLOB_TILDE
bsd_glob
glob
) ],
);
$EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}];
pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob"
@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
$VERSION = '1.28';
sub import {
require Exporter;
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
Exporter::import(grep {
my $passthrough;
if ($_ eq ':case') {
$DEFAULT_FLAGS &= ~GLOB_NOCASE()
}
elsif ($_ eq ':nocase') {
$DEFAULT_FLAGS |= GLOB_NOCASE();
}
elsif ($_ eq ':globally') {
no warnings 'redefine';
*CORE::GLOBAL::glob = \&File::Glob::csh_glob;
}
elsif ($_ eq ':bsd_glob') {
no strict; *{caller."::glob"} = \&bsd_glob_override;
$passthrough = 1;
}
else {
$passthrough = 1;
}
$passthrough;
} @_);
}
XSLoader::load();
$DEFAULT_FLAGS = GLOB_CSH();
if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) {
$DEFAULT_FLAGS |= GLOB_NOCASE();
}
# File::Glob::glob() is deprecated because its prototype is different from
# CORE::glob() (use bsd_glob() instead)
sub glob {
use 5.024;
use warnings ();
warnings::warnif (deprecated =>
"File::Glob::glob() will disappear in perl 5.30. " .
"Use File::Glob::bsd_glob() instead.") unless state $warned ++;
splice @_, 1; # no flags
goto &bsd_glob;
}
1;
__END__

583
vendor/LeOS/tools-leos/common/perl-base/File/Path.pm vendored
View File

@ -1,583 +0,0 @@
package File::Path;
use 5.005_04;
use strict;
use Cwd 'getcwd';
use File::Basename ();
use File::Spec ();
BEGIN {
if ( $] < 5.006 ) {
# can't say 'opendir my $dh, $dirname'
# need to initialise $dh
eval 'use Symbol';
}
}
use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION = '2.12_01';
$VERSION = eval $VERSION;
@ISA = qw(Exporter);
@EXPORT = qw(mkpath rmtree);
@EXPORT_OK = qw(make_path remove_tree);
BEGIN {
for (qw(VMS MacOS MSWin32 os2)) {
no strict 'refs';
*{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
}
# These OSes complain if you want to remove a file that you have no
# write permission to:
*_FORCE_WRITABLE = (
grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
) ? sub () { 1 } : sub () { 0 };
# Unix-like systems need to stat each directory in order to detect
# race condition. MS-Windows is immune to this particular attack.
*_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
}
sub _carp {
require Carp;
goto &Carp::carp;
}
sub _croak {
require Carp;
goto &Carp::croak;
}
sub _error {
my $arg = shift;
my $message = shift;
my $object = shift;
if ( $arg->{error} ) {
$object = '' unless defined $object;
$message .= ": $!" if $!;
push @{ ${ $arg->{error} } }, { $object => $message };
}
else {
_carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
}
}
sub __is_arg {
my ($arg) = @_;
# If client code blessed an array ref to HASH, this will not work
# properly. We could have done $arg->isa() wrapped in eval, but
# that would be expensive. This implementation should suffice.
# We could have also used Scalar::Util:blessed, but we choose not
# to add this dependency
return ( ref $arg eq 'HASH' );
}
sub make_path {
push @_, {} unless @_ and __is_arg( $_[-1] );
goto &mkpath;
}
sub mkpath {
my $old_style = !( @_ and __is_arg( $_[-1] ) );
my $arg;
my $paths;
if ($old_style) {
my ( $verbose, $mode );
( $paths, $verbose, $mode ) = @_;
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
$arg->{verbose} = $verbose;
$arg->{mode} = defined $mode ? $mode : oct '777';
}
else {
my %args_permitted = map { $_ => 1 } ( qw|
chmod
error
group
mask
mode
owner
uid
user
verbose
| );
my @bad_args = ();
$arg = pop @_;
for my $k (sort keys %{$arg}) {
push @bad_args, $k unless $args_permitted{$k};
}
_carp("Unrecognized option(s) passed to make_path(): @bad_args")
if @bad_args;
$arg->{mode} = delete $arg->{mask} if exists $arg->{mask};
$arg->{mode} = oct '777' unless exists $arg->{mode};
${ $arg->{error} } = [] if exists $arg->{error};
$arg->{owner} = delete $arg->{user} if exists $arg->{user};
$arg->{owner} = delete $arg->{uid} if exists $arg->{uid};
if ( exists $arg->{owner} and $arg->{owner} =~ /\D/ ) {
my $uid = ( getpwnam $arg->{owner} )[2];
if ( defined $uid ) {
$arg->{owner} = $uid;
}
else {
_error( $arg,
"unable to map $arg->{owner} to a uid, ownership not changed"
);
delete $arg->{owner};
}
}
if ( exists $arg->{group} and $arg->{group} =~ /\D/ ) {
my $gid = ( getgrnam $arg->{group} )[2];
if ( defined $gid ) {
$arg->{group} = $gid;
}
else {
_error( $arg,
"unable to map $arg->{group} to a gid, group ownership not changed"
);
delete $arg->{group};
}
}
if ( exists $arg->{owner} and not exists $arg->{group} ) {
$arg->{group} = -1; # chown will leave group unchanged
}
if ( exists $arg->{group} and not exists $arg->{owner} ) {
$arg->{owner} = -1; # chown will leave owner unchanged
}
$paths = [@_];
}
return _mkpath( $arg, $paths );
}
sub _mkpath {
my $arg = shift;
my $paths = shift;
my ( @created );
foreach my $path ( @{$paths} ) {
next unless defined($path) and length($path);
$path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT
# Logic wants Unix paths, so go with the flow.
if (_IS_VMS) {
next if $path eq '/';
$path = VMS::Filespec::unixify($path);
}
next if -d $path;
my $parent = File::Basename::dirname($path);
unless ( -d $parent or $path eq $parent ) {
push( @created, _mkpath( $arg, [$parent] ) );
}
print "mkdir $path\n" if $arg->{verbose};
if ( mkdir( $path, $arg->{mode} ) ) {
push( @created, $path );
if ( exists $arg->{owner} ) {
# NB: $arg->{group} guaranteed to be set during initialisation
if ( !chown $arg->{owner}, $arg->{group}, $path ) {
_error( $arg,
"Cannot change ownership of $path to $arg->{owner}:$arg->{group}"
);
}
}
if ( exists $arg->{chmod} ) {
if ( !chmod $arg->{chmod}, $path ) {
_error( $arg,
"Cannot change permissions of $path to $arg->{chmod}" );
}
}
}
else {
my $save_bang = $!;
my ( $e, $e1 ) = ( $save_bang, $^E );
$e .= "; $e1" if $e ne $e1;
# allow for another process to have created it meanwhile
if ( ! -d $path ) {
$! = $save_bang;
if ( $arg->{error} ) {
push @{ ${ $arg->{error} } }, { $path => $e };
}
else {
_croak("mkdir $path: $e");
}
}
}
}
return @created;
}
sub remove_tree {
push @_, {} unless @_ and __is_arg( $_[-1] );
goto &rmtree;
}
sub _is_subdir {
my ( $dir, $test ) = @_;
my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 );
my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
# not on same volume
return 0 if $dv ne $tv;
my @d = File::Spec->splitdir($dd);
my @t = File::Spec->splitdir($td);
# @t can't be a subdir if it's shorter than @d
return 0 if @t < @d;
return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
}
sub rmtree {
my $old_style = !( @_ and __is_arg( $_[-1] ) );
my $arg;
my $paths;
if ($old_style) {
my ( $verbose, $safe );
( $paths, $verbose, $safe ) = @_;
$arg->{verbose} = $verbose;
$arg->{safe} = defined $safe ? $safe : 0;
if ( defined($paths) and length($paths) ) {
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
}
else {
_carp("No root path(s) specified\n");
return 0;
}
}
else {
my %args_permitted = map { $_ => 1 } ( qw|
error
keep_root
result
safe
verbose
| );
my @bad_args = ();
$arg = pop @_;
for my $k (sort keys %{$arg}) {
push @bad_args, $k unless $args_permitted{$k};
}
_carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
if @bad_args;
${ $arg->{error} } = [] if exists $arg->{error};
${ $arg->{result} } = [] if exists $arg->{result};
$paths = [@_];
}
$arg->{prefix} = '';
$arg->{depth} = 0;
my @clean_path;
$arg->{cwd} = getcwd() or do {
_error( $arg, "cannot fetch initial working directory" );
return 0;
};
for ( $arg->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
for my $p (@$paths) {
# need to fixup case and map \ to / on Windows
my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
my $ortho_cwd =
_IS_MSWIN32 ? _slash_lc( $arg->{cwd} ) : $arg->{cwd};
my $ortho_root_length = length($ortho_root);
$ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
local $! = 0;
_error( $arg, "cannot remove path when cwd is $arg->{cwd}", $p );
next;
}
if (_IS_MACOS) {
$p = ":$p" unless $p =~ /:/;
$p .= ":" unless $p =~ /:\z/;
}
elsif ( _IS_MSWIN32 ) {
$p =~ s{[/\\]\z}{};
}
else {
$p =~ s{/\z}{};
}
push @clean_path, $p;
}
@{$arg}{qw(device inode perm)} = ( lstat $arg->{cwd} )[ 0, 1 ] or do {
_error( $arg, "cannot stat initial working directory", $arg->{cwd} );
return 0;
};
return _rmtree( $arg, \@clean_path );
}
sub _rmtree {
my $arg = shift;
my $paths = shift;
my $count = 0;
my $curdir = File::Spec->curdir();
my $updir = File::Spec->updir();
my ( @files, $root );
ROOT_DIR:
foreach my $root (@$paths) {
# since we chdir into each directory, it may not be obvious
# to figure out where we are if we generate a message about
# a file name. We therefore construct a semi-canonical
# filename, anchored from the directory being unlinked (as
# opposed to being truly canonical, anchored from the root (/).
my $canon =
$arg->{prefix}
? File::Spec->catfile( $arg->{prefix}, $root )
: $root;
my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
or next ROOT_DIR;
if ( -d _ ) {
$root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
if _IS_VMS;
if ( !chdir($root) ) {
# see if we can escalate privileges to get in
# (e.g. funny protection mask such as -w- instead of rwx)
# This uses fchmod to avoid traversing outside of the proper
# location (CVE-2017-6512)
my $root_fh;
if (open($root_fh, '<', $root)) {
my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
$perm &= oct '7777';
my $nperm = $perm | oct '700';
local $@;
if (
!(
$arg->{safe}
or $nperm == $perm
or !-d _
or $fh_dev ne $ldev
or $fh_inode ne $lino
or eval { chmod( $nperm, $root_fh ) }
)
)
{
_error( $arg,
"cannot make child directory read-write-exec", $canon );
next ROOT_DIR;
}
close $root_fh;
}
if ( !chdir($root) ) {
_error( $arg, "cannot chdir to child", $canon );
next ROOT_DIR;
}
}
my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
or do {
_error( $arg, "cannot stat current working directory", $canon );
next ROOT_DIR;
};
if (_NEED_STAT_CHECK) {
( $ldev eq $cur_dev and $lino eq $cur_inode )
or _croak(
"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
);
}
$perm &= oct '7777'; # don't forget setuid, setgid, sticky bits
my $nperm = $perm | oct '700';
# notabene: 0700 is for making readable in the first place,
# it's also intended to change it to writable in case we have
# to recurse in which case we are better than rm -rf for
# subtrees with strange permissions
if (
!(
$arg->{safe}
or $nperm == $perm
or chmod( $nperm, $curdir )
)
)
{
_error( $arg, "cannot make directory read+writeable", $canon );
$nperm = $perm;
}
my $d;
$d = gensym() if $] < 5.006;
if ( !opendir $d, $curdir ) {
_error( $arg, "cannot opendir", $canon );
@files = ();
}
else {
if ( !defined ${^TAINT} or ${^TAINT} ) {
# Blindly untaint dir names if taint mode is active
@files = map { /\A(.*)\z/s; $1 } readdir $d;
}
else {
@files = readdir $d;
}
closedir $d;
}
if (_IS_VMS) {
# Deleting large numbers of files from VMS Files-11
# filesystems is faster if done in reverse ASCIIbetical order.
# include '.' to '.;' from blead patch #31775
@files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
}
@files = grep { $_ ne $updir and $_ ne $curdir } @files;
if (@files) {
# remove the contained files before the directory itself
my $narg = {%$arg};
@{$narg}{qw(device inode cwd prefix depth)} =
( $cur_dev, $cur_inode, $updir, $canon, $arg->{depth} + 1 );
$count += _rmtree( $narg, \@files );
}
# restore directory permissions of required now (in case the rmdir
# below fails), while we are still in the directory and may do so
# without a race via '.'
if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
_error( $arg, "cannot reset chmod", $canon );
}
# don't leave the client code in an unexpected directory
chdir( $arg->{cwd} )
or
_croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
# ensure that a chdir upwards didn't take us somewhere other
# than we expected (see CVE-2002-0435)
( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
or _croak(
"cannot stat prior working directory $arg->{cwd}: $!, aborting."
);
if (_NEED_STAT_CHECK) {
( $arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode )
or _croak( "previous directory $arg->{cwd} "
. "changed before entering $canon, "
. "expected dev=$ldev ino=$lino, "
. "actual dev=$cur_dev ino=$cur_inode, aborting."
);
}
if ( $arg->{depth} or !$arg->{keep_root} ) {
if ( $arg->{safe}
&& ( _IS_VMS
? !&VMS::Filespec::candelete($root)
: !-w $root ) )
{
print "skipped $root\n" if $arg->{verbose};
next ROOT_DIR;
}
if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
_error( $arg, "cannot make directory writeable", $canon );
}
print "rmdir $root\n" if $arg->{verbose};
if ( rmdir $root ) {
push @{ ${ $arg->{result} } }, $root if $arg->{result};
++$count;
}
else {
_error( $arg, "cannot remove directory", $canon );
if (
_FORCE_WRITABLE
&& !chmod( $perm,
( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
)
)
{
_error(
$arg,
sprintf( "cannot restore permissions to 0%o",
$perm ),
$canon
);
}
}
}
}
else {
# not a directory
$root = VMS::Filespec::vmsify("./$root")
if _IS_VMS
&& !File::Spec->file_name_is_absolute($root)
&& ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax
if (
$arg->{safe}
&& (
_IS_VMS
? !&VMS::Filespec::candelete($root)
: !( -l $root || -w $root )
)
)
{
print "skipped $root\n" if $arg->{verbose};
next ROOT_DIR;
}
my $nperm = $perm & oct '7777' | oct '600';
if ( _FORCE_WRITABLE
and $nperm != $perm
and not chmod $nperm, $root )
{
_error( $arg, "cannot make file writeable", $canon );
}
print "unlink $canon\n" if $arg->{verbose};
# delete all versions under VMS
for ( ; ; ) {
if ( unlink $root ) {
push @{ ${ $arg->{result} } }, $root if $arg->{result};
}
else {
_error( $arg, "cannot unlink file", $canon );
_FORCE_WRITABLE and chmod( $perm, $root )
or _error( $arg,
sprintf( "cannot restore permissions to 0%o", $perm ),
$canon );
last;
}
++$count;
last unless _IS_VMS && lstat $root;
}
}
}
return $count;
}
sub _slash_lc {
# fix up slashes and case on MSWin32 so that we can determine that
# c:\path\to\dir is underneath C:/Path/To
my $path = shift;
$path =~ tr{\\}{/};
return lc($path);
}
1;
__END__

28
vendor/LeOS/tools-leos/common/perl-base/File/Spec.pm vendored
View File

@ -1,28 +0,0 @@
package File::Spec;
use strict;
use vars qw(@ISA $VERSION);
$VERSION = '3.67';
$VERSION =~ tr/_//d;
my %module = (MacOS => 'Mac',
MSWin32 => 'Win32',
os2 => 'OS2',
VMS => 'VMS',
epoc => 'Epoc',
NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
cygwin => 'Cygwin',
amigaos => 'AmigaOS');
my $module = $module{$^O} || 'Unix';
require "File/Spec/$module.pm";
@ISA = ("File::Spec::$module");
1;
__END__

341
vendor/LeOS/tools-leos/common/perl-base/File/Spec/Unix.pm vendored
View File

@ -1,341 +0,0 @@
package File::Spec::Unix;
use strict;
use vars qw($VERSION);
$VERSION = '3.67';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
#dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl
if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) {
eval {#eval is questionable since we are handling potential errors like
#"Cwd object version 3.48 does not match bootstrap parameter 3.50
#at lib/DynaLoader.pm line 216." by having this eval
if ( $] >= 5.006 ) {
require XSLoader;
XSLoader::load("Cwd", $xs_version);
} else {
require Cwd;
}
};
}
sub _pp_canonpath {
my ($self,$path) = @_;
return unless defined $path;
# Handle POSIX-style node names beginning with double slash (qnx, nto)
# (POSIX says: "a pathname that begins with two successive slashes
# may be interpreted in an implementation-defined manner, although
# more than two leading slashes shall be treated as a single slash.")
my $node = '';
my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
if ( $double_slashes_special
&& ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
$node = $1;
}
# This used to be
# $path =~ s|/+|/|g unless ($^O eq 'cygwin');
# but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
# (Mainly because trailing "" directories didn't get stripped).
# Why would cygwin avoid collapsing multiple slashes into one? --jhi
$path =~ s|/{2,}|/|g; # xx////xx -> xx/xx
$path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx
$path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx
$path =~ s|^/\.\.$|/|; # /.. -> /
$path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
return "$node$path";
}
*canonpath = \&_pp_canonpath unless defined &canonpath;
sub _pp_catdir {
my $self = shift;
$self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
}
*catdir = \&_pp_catdir unless defined &catdir;
sub _pp_catfile {
my $self = shift;
my $file = $self->canonpath(pop @_);
return $file unless @_;
my $dir = $self->catdir(@_);
$dir .= "/" unless substr($dir,-1) eq "/";
return $dir.$file;
}
*catfile = \&_pp_catfile unless defined &catfile;
sub curdir { '.' }
use constant _fn_curdir => ".";
sub devnull { '/dev/null' }
use constant _fn_devnull => "/dev/null";
sub rootdir { '/' }
use constant _fn_rootdir => "/";
my ($tmpdir, %tmpenv);
# Cache and return the calculated tmpdir, recording which env vars
# determined it.
sub _cache_tmpdir {
@tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]};
return $tmpdir = $_[1];
}
# Retrieve the cached tmpdir, checking first whether relevant env vars have
# changed and invalidated the cache.
sub _cached_tmpdir {
shift;
local $^W;
return if grep $ENV{$_} ne $tmpenv{$_}, @_;
return $tmpdir;
}
sub _tmpdir {
my $self = shift;
my @dirlist = @_;
my $taint = do { no strict 'refs'; ${"\cTAINT"} };
if ($taint) { # Check for taint mode on perl >= 5.8.0
require Scalar::Util;
@dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
}
elsif ($] < 5.007) { # No ${^TAINT} before 5.8
@dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
}
foreach (@dirlist) {
next unless defined && -d && -w _;
$tmpdir = $_;
last;
}
$tmpdir = $self->curdir unless defined $tmpdir;
$tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
if ( !$self->file_name_is_absolute($tmpdir) ) {
# See [perl #120593] for the full details
# If possible, return a full path, rather than '.' or 'lib', but
# jump through some hoops to avoid returning a tainted value.
($tmpdir) = grep {
$taint ? ! Scalar::Util::tainted($_) :
$] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
} $self->rel2abs($tmpdir), $tmpdir;
}
return $tmpdir;
}
sub tmpdir {
my $cached = $_[0]->_cached_tmpdir('TMPDIR');
return $cached if defined $cached;
$_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
}
sub updir { '..' }
use constant _fn_updir => "..";
sub no_upwards {
my $self = shift;
return grep(!/^\.{1,2}\z/s, @_);
}
sub case_tolerant { 0 }
use constant _fn_case_tolerant => 0;
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m:^/:s);
}
sub path {
return () unless exists $ENV{PATH};
my @path = split(':', $ENV{PATH});
foreach (@path) { $_ = '.' if $_ eq '' }
return @path;
}
sub join {
my $self = shift;
return $self->catfile(@_);
}
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
$directory = $path;
}
else {
$path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
$directory = $1;
$file = $2;
}
return ($volume,$directory,$file);
}
sub splitdir {
return split m|/|, $_[1], -1; # Preserve trailing fields
}
sub catpath {
my ($self,$volume,$directory,$file) = @_;
if ( $directory ne '' &&
$file ne '' &&
substr( $directory, -1 ) ne '/' &&
substr( $file, 0, 1 ) ne '/'
) {
$directory .= "/$file" ;
}
else {
$directory .= $file ;
}
return $directory ;
}
sub abs2rel {
my($self,$path,$base) = @_;
$base = $self->_cwd() unless defined $base and length $base;
($path, $base) = map $self->canonpath($_), $path, $base;
my $path_directories;
my $base_directories;
if (grep $self->file_name_is_absolute($_), $path, $base) {
($path, $base) = map $self->rel2abs($_), $path, $base;
my ($path_volume) = $self->splitpath($path, 1);
my ($base_volume) = $self->splitpath($base, 1);
# Can't relativize across volumes
return $path unless $path_volume eq $base_volume;
$path_directories = ($self->splitpath($path, 1))[1];
$base_directories = ($self->splitpath($base, 1))[1];
# For UNC paths, the user might give a volume like //foo/bar that
# strictly speaking has no directory portion. Treat it as if it
# had the root directory for that volume.
if (!length($base_directories) and $self->file_name_is_absolute($base)) {
$base_directories = $self->rootdir;
}
}
else {
my $wd= ($self->splitpath($self->_cwd(), 1))[1];
$path_directories = $self->catdir($wd, $path);
$base_directories = $self->catdir($wd, $base);
}
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
if ($base_directories eq $self->rootdir) {
return $self->curdir if $path_directories eq $self->rootdir;
shift @pathchunks;
return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
}
my @common;
while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
push @common, shift @pathchunks ;
shift @basechunks ;
}
return $self->curdir unless @pathchunks || @basechunks;
# @basechunks now contains the directories the resulting relative path
# must ascend out of before it can descend to $path_directory. If there
# are updir components, we must descend into the corresponding directories
# (this only works if they are no symlinks).
my @reverse_base;
while( defined(my $dir= shift @basechunks) ) {
if( $dir ne $self->updir ) {
unshift @reverse_base, $self->updir;
push @common, $dir;
}
elsif( @common ) {
if( @reverse_base && $reverse_base[0] eq $self->updir ) {
shift @reverse_base;
pop @common;
}
else {
unshift @reverse_base, pop @common;
}
}
}
my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
return $self->canonpath( $self->catpath('', $result_dirs, '') );
}
sub _same {
$_[1] eq $_[2];
}
sub rel2abs {
my ($self,$path,$base ) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd();
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Glom them together
$path = $self->catdir( $base, $path ) ;
}
return $self->canonpath( $path ) ;
}
# Internal routine to File::Spec, no point in making this public since
# it is the standard Cwd interface. Most of the platform-specific
# File::Spec subclasses use this.
sub _cwd {
require Cwd;
Cwd::getcwd();
}
# Internal method to reduce xx\..\yy -> yy
sub _collapse {
my($fs, $path) = @_;
my $updir = $fs->updir;
my $curdir = $fs->curdir;
my($vol, $dirs, $file) = $fs->splitpath($path);
my @dirs = $fs->splitdir($dirs);
pop @dirs if @dirs && $dirs[-1] eq '';
my @collapsed;
foreach my $dir (@dirs) {
if( $dir eq $updir and # if we have an updir
@collapsed and # and something to collapse
length $collapsed[-1] and # and its not the rootdir
$collapsed[-1] ne $updir and # nor another updir
$collapsed[-1] ne $curdir # nor the curdir
)
{ # then
pop @collapsed; # collapse
}
else { # else
push @collapsed, $dir; # just hang onto it
}
}
return $fs->catpath($vol,
$fs->catdir(@collapsed),
$file
);
}
1;

1592
vendor/LeOS/tools-leos/common/perl-base/File/Temp.pm vendored
View File

File diff suppressed because it is too large Load Diff

105
vendor/LeOS/tools-leos/common/perl-base/FileHandle.pm vendored
View File

@ -1,105 +0,0 @@
package FileHandle;
use 5.006;
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
$VERSION = "2.03";
require IO::File;
@ISA = qw(IO::File);
@EXPORT = qw(_IOFBF _IOLBF _IONBF);
@EXPORT_OK = qw(
pipe
autoflush
output_field_separator
output_record_separator
input_record_separator
input_line_number
format_page_number
format_lines_per_page
format_lines_left
format_name
format_top_name
format_line_break_characters
format_formfeed
print
printf
getline
getlines
);
#
# Everything we're willing to export, we must first import.
#
IO::Handle->import( grep { !defined(&$_) } @EXPORT, @EXPORT_OK );
#
# Some people call "FileHandle::function", so all the functions
# that were in the old FileHandle class must be imported, too.
#
{
no strict 'refs';
my %import = (
'IO::Handle' =>
[qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
eof flush error clearerr setbuf setvbuf _open_mode_string)],
'IO::Seekable' =>
[qw(seek tell getpos setpos)],
'IO::File' =>
[qw(new new_tmpfile open)]
);
for my $pkg (keys %import) {
for my $func (@{$import{$pkg}}) {
my $c = *{"${pkg}::$func"}{CODE}
or die "${pkg}::$func missing";
*$func = $c;
}
}
}
#
# Specialized importer for Fcntl magic.
#
sub import {
my $pkg = shift;
my $callpkg = caller;
require Exporter;
Exporter::export($pkg, $callpkg, @_);
#
# If the Fcntl extension is available,
# export its constants.
#
eval {
require Fcntl;
Exporter::export('Fcntl', $callpkg);
};
}
################################################
# This is the only exported function we define;
# the rest come from other classes.
#
sub pipe {
my $r = IO::Handle->new;
my $w = IO::Handle->new;
CORE::pipe($r, $w) or return undef;
($r, $w);
}
# Rebless standard file handles
bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle";
bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
1;
__END__

1572
vendor/LeOS/tools-leos/common/perl-base/Getopt/Long.pm vendored
View File

File diff suppressed because it is too large Load Diff

300
vendor/LeOS/tools-leos/common/perl-base/Hash/Util.pm vendored
View File

@ -1,300 +0,0 @@
package Hash::Util;
require 5.007003;
use strict;
use Carp;
use warnings;
no warnings 'uninitialized';
use warnings::register;
use Scalar::Util qw(reftype);
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
fieldhash fieldhashes
all_keys
lock_keys unlock_keys
lock_value unlock_value
lock_hash unlock_hash
lock_keys_plus
hash_locked hash_unlocked
hashref_locked hashref_unlocked
hidden_keys legal_keys
lock_ref_keys unlock_ref_keys
lock_ref_value unlock_ref_value
lock_hashref unlock_hashref
lock_ref_keys_plus
hidden_ref_keys legal_ref_keys
hash_seed hash_value hv_store
bucket_stats bucket_stats_formatted bucket_info bucket_array
lock_hash_recurse unlock_hash_recurse
lock_hashref_recurse unlock_hashref_recurse
hash_traversal_mask
bucket_ratio
used_buckets
num_buckets
);
BEGIN {
# make sure all our XS routines are available early so their prototypes
# are correctly applied in the following code.
our $VERSION = '0.22';
require XSLoader;
XSLoader::load();
}
sub import {
my $class = shift;
if ( grep /fieldhash/, @_ ) {
require Hash::Util::FieldHash;
Hash::Util::FieldHash->import(':all'); # for re-export
}
unshift @_, $class;
goto &Exporter::import;
}
sub lock_ref_keys {
my($hash, @keys) = @_;
_clear_placeholders(%$hash);
if( @keys ) {
my %keys = map { ($_ => 1) } @keys;
my %original_keys = map { ($_ => 1) } keys %$hash;
foreach my $k (keys %original_keys) {
croak "Hash has key '$k' which is not in the new key set"
unless $keys{$k};
}
foreach my $k (@keys) {
$hash->{$k} = undef unless exists $hash->{$k};
}
Internals::SvREADONLY %$hash, 1;
foreach my $k (@keys) {
delete $hash->{$k} unless $original_keys{$k};
}
}
else {
Internals::SvREADONLY %$hash, 1;
}
return $hash;
}
sub unlock_ref_keys {
my $hash = shift;
Internals::SvREADONLY %$hash, 0;
return $hash;
}
sub lock_keys (\%;@) { lock_ref_keys(@_) }
sub unlock_keys (\%) { unlock_ref_keys(@_) }
#=item B<_clear_placeholders>
#
# This function removes any placeholder keys from a hash. See Perl_hv_clear_placeholders()
# in hv.c for what it does exactly. It is currently exposed as XS by universal.c and
# injected into the Hash::Util namespace.
#
# It is not intended for use outside of this module, and may be changed
# or removed without notice or deprecation cycle.
#
#=cut
#
# sub _clear_placeholders {} # just in case someone searches...
sub lock_ref_keys_plus {
my ($hash,@keys) = @_;
my @delete;
_clear_placeholders(%$hash);
foreach my $key (@keys) {
unless (exists($hash->{$key})) {
$hash->{$key}=undef;
push @delete,$key;
}
}
Internals::SvREADONLY(%$hash,1);
delete @{$hash}{@delete};
return $hash
}
sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
sub lock_ref_value {
my($hash, $key) = @_;
# I'm doubtful about this warning, as it seems not to be true.
# Marking a value in the hash as RO is useful, regardless
# of the status of the hash itself.
carp "Cannot usefully lock values in an unlocked hash"
if !Internals::SvREADONLY(%$hash) && warnings::enabled;
Internals::SvREADONLY $hash->{$key}, 1;
return $hash
}
sub unlock_ref_value {
my($hash, $key) = @_;
Internals::SvREADONLY $hash->{$key}, 0;
return $hash
}
sub lock_value (\%$) { lock_ref_value(@_) }
sub unlock_value (\%$) { unlock_ref_value(@_) }
sub lock_hashref {
my $hash = shift;
lock_ref_keys($hash);
foreach my $value (values %$hash) {
Internals::SvREADONLY($value,1);
}
return $hash;
}
sub unlock_hashref {
my $hash = shift;
foreach my $value (values %$hash) {
Internals::SvREADONLY($value, 0);
}
unlock_ref_keys($hash);
return $hash;
}
sub lock_hash (\%) { lock_hashref(@_) }
sub unlock_hash (\%) { unlock_hashref(@_) }
sub lock_hashref_recurse {
my $hash = shift;
lock_ref_keys($hash);
foreach my $value (values %$hash) {
my $type = reftype($value);
if (defined($type) and $type eq 'HASH') {
lock_hashref_recurse($value);
}
Internals::SvREADONLY($value,1);
}
return $hash
}
sub unlock_hashref_recurse {
my $hash = shift;
foreach my $value (values %$hash) {
my $type = reftype($value);
if (defined($type) and $type eq 'HASH') {
unlock_hashref_recurse($value);
}
Internals::SvREADONLY($value,0);
}
unlock_ref_keys($hash);
return $hash;
}
sub lock_hash_recurse (\%) { lock_hashref_recurse(@_) }
sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
sub hashref_locked {
my $hash=shift;
Internals::SvREADONLY(%$hash);
}
sub hash_locked(\%) { hashref_locked(@_) }
sub hashref_unlocked {
my $hash=shift;
!Internals::SvREADONLY(%$hash);
}
sub hash_unlocked(\%) { hashref_unlocked(@_) }
sub legal_keys(\%) { legal_ref_keys(@_) }
sub hidden_keys(\%){ hidden_ref_keys(@_) }
sub bucket_stats {
my ($hash) = @_;
my ($keys, $buckets, $used, @length_counts) = bucket_info($hash);
my $sum;
my $score;
for (1 .. $#length_counts) {
$sum += ($length_counts[$_] * $_);
$score += $length_counts[$_] * ( $_ * ($_ + 1 ) / 2 );
}
$score = $score /
(( $keys / (2 * $buckets )) * ( $keys + ( 2 * $buckets ) - 1 ))
if $keys;
my ($mean, $stddev)= (0, 0);
if ($used) {
$mean= $sum / $used;
$sum= 0;
$sum += ($length_counts[$_] * (($_-$mean)**2)) for 1 .. $#length_counts;
$stddev= sqrt($sum/$used);
}
return $keys, $buckets, $used, $keys ? ($score, $used/$buckets, ($keys-$used)/$keys, $mean, $stddev, @length_counts) : ();
}
sub _bucket_stats_formatted_bars {
my ($total, $ary, $start_idx, $title, $row_title)= @_;
my $return = "";
my $max_width= $total > 64 ? 64 : $total;
my $bar_width= $max_width / $total;
my $str= "";
if ( @$ary < 10) {
for my $idx ($start_idx .. $#$ary) {
$str .= $idx x sprintf("%.0f", ($ary->[$idx] * $bar_width));
}
} else {
$str= "-" x $max_width;
}
$return .= sprintf "%-7s %6d [%s]\n",$title, $total, $str;
foreach my $idx ($start_idx .. $#$ary) {
$return .= sprintf "%-.3s %3d %6.2f%% %6d [%s]\n",
$row_title,
$idx,
$ary->[$idx] / $total * 100,
$ary->[$idx],
"#" x sprintf("%.0f", ($ary->[$idx] * $bar_width)),
;
}
return $return;
}
sub bucket_stats_formatted {
my ($hashref)= @_;
my ($keys, $buckets, $used, $score, $utilization_ratio, $collision_pct,
$mean, $stddev, @length_counts) = bucket_stats($hashref);
my $return= sprintf "Keys: %d Buckets: %d/%d Quality-Score: %.2f (%s)\n"
. "Utilized Buckets: %.2f%% Optimal: %.2f%% Keys In Collision: %.2f%%\n"
. "Chain Length - mean: %.2f stddev: %.2f\n",
$keys, $used, $buckets, $score, $score <= 1.05 ? "Good" : $score < 1.2 ? "Poor" : "Bad",
$utilization_ratio * 100,
$keys/$buckets * 100,
$collision_pct * 100,
$mean, $stddev;
my @key_depth;
$key_depth[$_]= $length_counts[$_] + ( $key_depth[$_+1] || 0 )
for reverse 1 .. $#length_counts;
if ($keys) {
$return .= _bucket_stats_formatted_bars($buckets, \@length_counts, 0, "Buckets", "Len");
$return .= _bucket_stats_formatted_bars($keys, \@key_depth, 1, "Keys", "Pos");
}
return $return
}
1;

30
vendor/LeOS/tools-leos/common/perl-base/IO.pm vendored
View File

@ -1,30 +0,0 @@
#
package IO;
use XSLoader ();
use Carp;
use strict;
use warnings;
our $VERSION = "1.38";
XSLoader::load 'IO', $VERSION;
sub import {
shift;
warnings::warnif('deprecated', qq{Parameterless "use IO" deprecated})
if @_ == 0 ;
my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir);
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l)
or croak $@;
}
1;
__END__

81
vendor/LeOS/tools-leos/common/perl-base/IO/File.pm vendored
View File

@ -1,81 +0,0 @@
#
package IO::File;
use 5.006_001;
use strict;
our($VERSION, @EXPORT, @EXPORT_OK, @ISA);
use Carp;
use Symbol;
use SelectSaver;
use IO::Seekable;
require Exporter;
@ISA = qw(IO::Handle IO::Seekable Exporter);
$VERSION = "1.16";
@EXPORT = @IO::Seekable::EXPORT;
eval {
# Make all Fcntl O_XXX constants available for importing
require Fcntl;
my @O = grep /^O_/, @Fcntl::EXPORT;
Fcntl->import(@O); # first we import what we want to export
push(@EXPORT, @O);
};
################################################
## Constructor
##
sub new {
my $type = shift;
my $class = ref($type) || $type || "IO::File";
@_ >= 0 && @_ <= 3
or croak "usage: $class->new([FILENAME [,MODE [,PERMS]]])";
my $fh = $class->SUPER::new();
if (@_) {
$fh->open(@_)
or return undef;
}
$fh;
}
################################################
## Open
##
sub open {
@_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
my ($fh, $file) = @_;
if (@_ > 2) {
my ($mode, $perms) = @_[2, 3];
if ($mode =~ /^\d+$/) {
defined $perms or $perms = 0666;
return sysopen($fh, $file, $mode, $perms);
} elsif ($mode =~ /:/) {
return open($fh, $mode, $file) if @_ == 3;
croak 'usage: $fh->open(FILENAME, IOLAYERS)';
} else {
return open($fh, IO::Handle::_open_mode_string($mode), $file);
}
}
open($fh, $file);
}
################################################
## Binmode
##
sub binmode {
( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])';
my($fh, $layer) = @_;
return binmode $$fh unless $layer;
return binmode $$fh, $layer;
}
1;

391
vendor/LeOS/tools-leos/common/perl-base/IO/Handle.pm vendored
View File

@ -1,391 +0,0 @@
package IO::Handle;
use 5.006_001;
use strict;
our($VERSION, @EXPORT_OK, @ISA);
use Carp;
use Symbol;
use SelectSaver;
use IO (); # Load the XS module
require Exporter;
@ISA = qw(Exporter);
$VERSION = "1.36";
$VERSION = eval $VERSION;
@EXPORT_OK = qw(
autoflush
output_field_separator
output_record_separator
input_record_separator
input_line_number
format_page_number
format_lines_per_page
format_lines_left
format_name
format_top_name
format_line_break_characters
format_formfeed
format_write
print
printf
say
getline
getlines
printflush
flush
SEEK_SET
SEEK_CUR
SEEK_END
_IOFBF
_IOLBF
_IONBF
);
################################################
## Constructors, destructors.
##
sub new {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
if (@_ != 1) {
# Since perl will automatically require IO::File if needed, but
# also initialises IO::File's @ISA as part of the core we must
# ensure IO::File is loaded if IO::Handle is. This avoids effect-
# ively "half-loading" IO::File.
if ($] > 5.013 && $class eq 'IO::File' && !$INC{"IO/File.pm"}) {
require IO::File;
shift;
return IO::File::->new(@_);
}
croak "usage: $class->new()";
}
my $io = gensym;
bless $io, $class;
}
sub new_from_fd {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
@_ == 3 or croak "usage: $class->new_from_fd(FD, MODE)";
my $io = gensym;
shift;
IO::Handle::fdopen($io, @_)
or return undef;
bless $io, $class;
}
#
# There is no need for DESTROY to do anything, because when the
# last reference to an IO object is gone, Perl automatically
# closes its associated files (if any). However, to avoid any
# attempts to autoload DESTROY, we here define it to do nothing.
#
sub DESTROY {}
################################################
## Open and close.
##
sub _open_mode_string {
my ($mode) = @_;
$mode =~ /^\+?(<|>>?)$/
or $mode =~ s/^r(\+?)$/$1</
or $mode =~ s/^w(\+?)$/$1>/
or $mode =~ s/^a(\+?)$/$1>>/
or croak "IO::Handle: bad open mode: $mode";
$mode;
}
sub fdopen {
@_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
my ($io, $fd, $mode) = @_;
local(*GLOB);
if (ref($fd) && "".$fd =~ /GLOB\(/o) {
# It's a glob reference; Alias it as we cannot get name of anon GLOBs
my $n = qualify(*GLOB);
*GLOB = *{*$fd};
$fd = $n;
} elsif ($fd =~ m#^\d+$#) {
# It's an FD number; prefix with "=".
$fd = "=$fd";
}
open($io, _open_mode_string($mode) . '&' . $fd)
? $io : undef;
}
sub close {
@_ == 1 or croak 'usage: $io->close()';
my($io) = @_;
close($io);
}
################################################
## Normal I/O functions.
##
# flock
# select
sub opened {
@_ == 1 or croak 'usage: $io->opened()';
defined fileno($_[0]);
}
sub fileno {
@_ == 1 or croak 'usage: $io->fileno()';
fileno($_[0]);
}
sub getc {
@_ == 1 or croak 'usage: $io->getc()';
getc($_[0]);
}
sub eof {
@_ == 1 or croak 'usage: $io->eof()';
eof($_[0]);
}
sub print {
@_ or croak 'usage: $io->print(ARGS)';
my $this = shift;
print $this @_;
}
sub printf {
@_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
my $this = shift;
printf $this @_;
}
sub say {
@_ or croak 'usage: $io->say(ARGS)';
my $this = shift;
local $\ = "\n";
print $this @_;
}
# Special XS wrapper to make them inherit lexical hints from the caller.
_create_getline_subs( <<'END' ) or die $@;
sub getline {
@_ == 1 or croak 'usage: $io->getline()';
my $this = shift;
return scalar <$this>;
}
sub getlines {
@_ == 1 or croak 'usage: $io->getlines()';
wantarray or
croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
my $this = shift;
return <$this>;
}
1; # return true for error checking
END
*gets = \&getline; # deprecated
sub truncate {
@_ == 2 or croak 'usage: $io->truncate(LEN)';
truncate($_[0], $_[1]);
}
sub read {
@_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
read($_[0], $_[1], $_[2], $_[3] || 0);
}
sub sysread {
@_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
sysread($_[0], $_[1], $_[2], $_[3] || 0);
}
sub write {
@_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
local($\) = "";
$_[2] = length($_[1]) unless defined $_[2];
print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
}
sub syswrite {
@_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
if (defined($_[2])) {
syswrite($_[0], $_[1], $_[2], $_[3] || 0);
} else {
syswrite($_[0], $_[1]);
}
}
sub stat {
@_ == 1 or croak 'usage: $io->stat()';
stat($_[0]);
}
################################################
## State modification functions.
##
sub autoflush {
my $old = new SelectSaver qualify($_[0], caller);
my $prev = $|;
$| = @_ > 1 ? $_[1] : 1;
$prev;
}
sub output_field_separator {
carp "output_field_separator is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $,;
$, = $_[1] if @_ > 1;
$prev;
}
sub output_record_separator {
carp "output_record_separator is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $\;
$\ = $_[1] if @_ > 1;
$prev;
}
sub input_record_separator {
carp "input_record_separator is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $/;
$/ = $_[1] if @_ > 1;
$prev;
}
sub input_line_number {
local $.;
() = tell qualify($_[0], caller) if ref($_[0]);
my $prev = $.;
$. = $_[1] if @_ > 1;
$prev;
}
sub format_page_number {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $%;
$% = $_[1] if @_ > 1;
$prev;
}
sub format_lines_per_page {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $=;
$= = $_[1] if @_ > 1;
$prev;
}
sub format_lines_left {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $-;
$- = $_[1] if @_ > 1;
$prev;
}
sub format_name {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $~;
$~ = qualify($_[1], caller) if @_ > 1;
$prev;
}
sub format_top_name {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $^;
$^ = qualify($_[1], caller) if @_ > 1;
$prev;
}
sub format_line_break_characters {
carp "format_line_break_characters is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $:;
$: = $_[1] if @_ > 1;
$prev;
}
sub format_formfeed {
carp "format_formfeed is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $^L;
$^L = $_[1] if @_ > 1;
$prev;
}
sub formline {
my $io = shift;
my $picture = shift;
local($^A) = $^A;
local($\) = "";
formline($picture, @_);
print $io $^A;
}
sub format_write {
@_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
if (@_ == 2) {
my ($io, $fmt) = @_;
my $oldfmt = $io->format_name(qualify($fmt,caller));
CORE::write($io);
$io->format_name($oldfmt);
} else {
CORE::write($_[0]);
}
}
sub fcntl {
@_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
my ($io, $op) = @_;
return fcntl($io, $op, $_[2]);
}
sub ioctl {
@_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
my ($io, $op) = @_;
return ioctl($io, $op, $_[2]);
}
# this sub is for compatibility with older releases of IO that used
# a sub called constant to determine if a constant existed -- GMB
#
# The SEEK_* and _IO?BF constants were the only constants at that time
# any new code should just check defined(&CONSTANT_NAME)
sub constant {
no strict 'refs';
my $name = shift;
(($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
? &{$name}() : undef;
}
# so that flush.pl can be deprecated
sub printflush {
my $io = shift;
my $old;
$old = new SelectSaver qualify($io, caller) if ref($io);
local $| = 1;
if(ref($io)) {
print $io @_;
}
else {
print @_;
}
}
1;

160
vendor/LeOS/tools-leos/common/perl-base/IO/Pipe.pm vendored
View File

@ -1,160 +0,0 @@
# IO::Pipe.pm
#
# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Pipe;
use 5.006_001;
use IO::Handle;
use strict;
our($VERSION);
use Carp;
use Symbol;
$VERSION = "1.15";
sub new {
my $type = shift;
my $class = ref($type) || $type || "IO::Pipe";
@_ == 0 || @_ == 2 or croak "usage: $class->([READFH, WRITEFH])";
my $me = bless gensym(), $class;
my($readfh,$writefh) = @_ ? @_ : $me->handles;
pipe($readfh, $writefh)
or return undef;
@{*$me} = ($readfh, $writefh);
$me;
}
sub handles {
@_ == 1 or croak 'usage: $pipe->handles()';
(IO::Pipe::End->new(), IO::Pipe::End->new());
}
my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
sub _doit {
my $me = shift;
my $rw = shift;
my $pid = $do_spawn ? 0 : fork();
if($pid) { # Parent
return $pid;
}
elsif(defined $pid) { # Child or spawn
my $fh;
my $io = $rw ? \*STDIN : \*STDOUT;
my ($mode, $save) = $rw ? "r" : "w";
if ($do_spawn) {
require Fcntl;
$save = IO::Handle->new_from_fd($io, $mode);
my $handle = shift;
# Close in child:
unless ($^O eq 'MSWin32') {
fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
}
$fh = $rw ? ${*$me}[0] : ${*$me}[1];
} else {
shift;
$fh = $rw ? $me->reader() : $me->writer(); # close the other end
}
bless $io, "IO::Handle";
$io->fdopen($fh, $mode);
$fh->close;
if ($do_spawn) {
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
my $err = $!;
$io->fdopen($save, $mode);
$save->close or croak "Cannot close $!";
croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
return $pid;
} else {
exec @_ or
croak "IO::Pipe: Cannot exec: $!";
}
}
else {
croak "IO::Pipe: Cannot fork: $!";
}
# NOT Reached
}
sub reader {
@_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
my $me = shift;
return undef
unless(ref($me) || ref($me = $me->new));
my $fh = ${*$me}[0];
my $pid;
$pid = $me->_doit(0, $fh, @_)
if(@_);
close ${*$me}[1];
bless $me, ref($fh);
*$me = *$fh; # Alias self to handle
$me->fdopen($fh->fileno,"r")
unless defined($me->fileno);
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
$me;
}
sub writer {
@_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
my $me = shift;
return undef
unless(ref($me) || ref($me = $me->new));
my $fh = ${*$me}[1];
my $pid;
$pid = $me->_doit(1, $fh, @_)
if(@_);
close ${*$me}[0];
bless $me, ref($fh);
*$me = *$fh; # Alias self to handle
$me->fdopen($fh->fileno,"w")
unless defined($me->fileno);
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
$me;
}
package IO::Pipe::End;
our(@ISA);
@ISA = qw(IO::Handle);
sub close {
my $fh = shift;
my $r = $fh->SUPER::close(@_);
waitpid(${*$fh}{'io_pipe_pid'},0)
if(defined ${*$fh}{'io_pipe_pid'});
$r;
}
1;
__END__

36
vendor/LeOS/tools-leos/common/perl-base/IO/Seekable.pm vendored
View File

@ -1,36 +0,0 @@
#
package IO::Seekable;
use 5.006_001;
use Carp;
use strict;
our($VERSION, @EXPORT, @ISA);
use IO::Handle ();
# XXX we can't get these from IO::Handle or we'll get prototype
# mismatch warnings on C<use POSIX; use IO::File;> :-(
use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END);
require Exporter;
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
$VERSION = "1.10";
$VERSION = eval $VERSION;
sub seek {
@_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
seek($_[0], $_[1], $_[2]);
}
sub sysseek {
@_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)';
sysseek($_[0], $_[1], $_[2]);
}
sub tell {
@_ == 1 or croak 'usage: $io->tell()';
tell($_[0]);
}
1;

248
vendor/LeOS/tools-leos/common/perl-base/IO/Select.pm vendored
View File

@ -1,248 +0,0 @@
# IO::Select.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Select;
use strict;
use warnings::register;
use vars qw($VERSION @ISA);
require Exporter;
$VERSION = "1.22";
@ISA = qw(Exporter); # This is only so we can do version checking
sub VEC_BITS () {0}
sub FD_COUNT () {1}
sub FIRST_FD () {2}
sub new
{
my $self = shift;
my $type = ref($self) || $self;
my $vec = bless [undef,0], $type;
$vec->add(@_)
if @_;
$vec;
}
sub add
{
shift->_update('add', @_);
}
sub remove
{
shift->_update('remove', @_);
}
sub exists
{
my $vec = shift;
my $fno = $vec->_fileno(shift);
return undef unless defined $fno;
$vec->[$fno + FIRST_FD];
}
sub _fileno
{
my($self, $f) = @_;
return unless defined $f;
$f = $f->[0] if ref($f) eq 'ARRAY';
($f =~ /^\d+$/) ? $f : fileno($f);
}
sub _update
{
my $vec = shift;
my $add = shift eq 'add';
my $bits = $vec->[VEC_BITS];
$bits = '' unless defined $bits;
my $count = 0;
my $f;
foreach $f (@_)
{
my $fn = $vec->_fileno($f);
if ($add) {
next unless defined $fn;
my $i = $fn + FIRST_FD;
if (defined $vec->[$i]) {
$vec->[$i] = $f; # if array rest might be different, so we update
next;
}
$vec->[FD_COUNT]++;
vec($bits, $fn, 1) = 1;
$vec->[$i] = $f;
} else { # remove
if ( ! defined $fn ) { # remove if fileno undef'd
$fn = 0;
for my $fe (@{$vec}[FIRST_FD .. $#$vec]) {
if (defined($fe) && $fe == $f) {
$vec->[FD_COUNT]--;
$fe = undef;
vec($bits, $fn, 1) = 0;
last;
}
++$fn;
}
}
else {
my $i = $fn + FIRST_FD;
next unless defined $vec->[$i];
$vec->[FD_COUNT]--;
vec($bits, $fn, 1) = 0;
$vec->[$i] = undef;
}
}
$count++;
}
$vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
$count;
}
sub can_read
{
my $vec = shift;
my $timeout = shift;
my $r = $vec->[VEC_BITS];
defined($r) && (select($r,undef,undef,$timeout) > 0)
? handles($vec, $r)
: ();
}
sub can_write
{
my $vec = shift;
my $timeout = shift;
my $w = $vec->[VEC_BITS];
defined($w) && (select(undef,$w,undef,$timeout) > 0)
? handles($vec, $w)
: ();
}
sub has_exception
{
my $vec = shift;
my $timeout = shift;
my $e = $vec->[VEC_BITS];
defined($e) && (select(undef,undef,$e,$timeout) > 0)
? handles($vec, $e)
: ();
}
sub has_error
{
warnings::warn("Call to deprecated method 'has_error', use 'has_exception'")
if warnings::enabled();
goto &has_exception;
}
sub count
{
my $vec = shift;
$vec->[FD_COUNT];
}
sub bits
{
my $vec = shift;
$vec->[VEC_BITS];
}
sub as_string # for debugging
{
my $vec = shift;
my $str = ref($vec) . ": ";
my $bits = $vec->bits;
my $count = $vec->count;
$str .= defined($bits) ? unpack("b*", $bits) : "undef";
$str .= " $count";
my @handles = @$vec;
splice(@handles, 0, FIRST_FD);
for (@handles) {
$str .= " " . (defined($_) ? "$_" : "-");
}
$str;
}
sub _max
{
my($a,$b,$c) = @_;
$a > $b
? $a > $c
? $a
: $c
: $b > $c
? $b
: $c;
}
sub select
{
shift
if defined $_[0] && !ref($_[0]);
my($r,$w,$e,$t) = @_;
my @result = ();
my $rb = defined $r ? $r->[VEC_BITS] : undef;
my $wb = defined $w ? $w->[VEC_BITS] : undef;
my $eb = defined $e ? $e->[VEC_BITS] : undef;
if(select($rb,$wb,$eb,$t) > 0)
{
my @r = ();
my @w = ();
my @e = ();
my $i = _max(defined $r ? scalar(@$r)-1 : 0,
defined $w ? scalar(@$w)-1 : 0,
defined $e ? scalar(@$e)-1 : 0);
for( ; $i >= FIRST_FD ; $i--)
{
my $j = $i - FIRST_FD;
push(@r, $r->[$i])
if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
push(@w, $w->[$i])
if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
push(@e, $e->[$i])
if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
}
@result = (\@r, \@w, \@e);
}
@result;
}
sub handles
{
my $vec = shift;
my $bits = shift;
my @h = ();
my $i;
my $max = scalar(@$vec) - 1;
for ($i = FIRST_FD; $i <= $max; $i++)
{
next unless defined $vec->[$i];
push(@h, $vec->[$i])
if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
}
@h;
}
1;
__END__

381
vendor/LeOS/tools-leos/common/perl-base/IO/Socket.pm vendored
View File

@ -1,381 +0,0 @@
# IO::Socket.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket;
require 5.006;
use IO::Handle;
use Socket 1.3;
use Carp;
use strict;
our(@ISA, $VERSION, @EXPORT_OK);
use Exporter;
use Errno;
# legacy
require IO::Socket::INET;
require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
@ISA = qw(IO::Handle);
$VERSION = "1.38";
@EXPORT_OK = qw(sockatmark);
sub import {
my $pkg = shift;
if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
} else {
my $callpkg = caller;
Exporter::export 'Socket', $callpkg, @_;
}
}
sub new {
my($class,%arg) = @_;
my $sock = $class->SUPER::new();
$sock->autoflush(1);
${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
return scalar(%arg) ? $sock->configure(\%arg)
: $sock;
}
my @domain2pkg;
sub register_domain {
my($p,$d) = @_;
$domain2pkg[$d] = $p;
}
sub configure {
my($sock,$arg) = @_;
my $domain = delete $arg->{Domain};
croak 'IO::Socket: Cannot configure a generic socket'
unless defined $domain;
croak "IO::Socket: Unsupported socket domain"
unless defined $domain2pkg[$domain];
croak "IO::Socket: Cannot configure socket in domain '$domain'"
unless ref($sock) eq "IO::Socket";
bless($sock, $domain2pkg[$domain]);
$sock->configure($arg);
}
sub socket {
@_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
my($sock,$domain,$type,$protocol) = @_;
socket($sock,$domain,$type,$protocol) or
return undef;
${*$sock}{'io_socket_domain'} = $domain;
${*$sock}{'io_socket_type'} = $type;
${*$sock}{'io_socket_proto'} = $protocol;
$sock;
}
sub socketpair {
@_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
my($class,$domain,$type,$protocol) = @_;
my $sock1 = $class->new();
my $sock2 = $class->new();
socketpair($sock1,$sock2,$domain,$type,$protocol) or
return ();
${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
($sock1,$sock2);
}
sub connect {
@_ == 2 or croak 'usage: $sock->connect(NAME)';
my $sock = shift;
my $addr = shift;
my $timeout = ${*$sock}{'io_socket_timeout'};
my $err;
my $blocking;
$blocking = $sock->blocking(0) if $timeout;
if (!connect($sock, $addr)) {
if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
require IO::Select;
my $sel = new IO::Select $sock;
undef $!;
my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
if(@$e[0]) {
# Windows return from select after the timeout in case of
# WSAECONNREFUSED(10061) if exception set is not used.
# This behavior is different from Linux.
# Using the exception
# set we now emulate the behavior in Linux
# - Karthik Rajagopalan
$err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
$@ = "connect: $err";
}
elsif(!@$w[0]) {
$err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
$@ = "connect: timeout";
}
elsif (!connect($sock,$addr) &&
not ($!{EISCONN} || ($^O eq 'MSWin32' &&
($! == (($] < 5.019004) ? 10022 : Errno::EINVAL))))
) {
# Some systems refuse to re-connect() to
# an already open socket and set errno to EISCONN.
# Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
# EINVAL (22) (5.19.4 onwards).
$err = $!;
$@ = "connect: $!";
}
}
elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
$err = $!;
$@ = "connect: $!";
}
}
$sock->blocking(1) if $blocking;
$! = $err if $err;
$err ? undef : $sock;
}
# Enable/disable blocking IO on sockets.
# Without args return the current status of blocking,
# with args change the mode as appropriate, returning the
# old setting, or in case of error during the mode change
# undef.
sub blocking {
my $sock = shift;
return $sock->SUPER::blocking(@_)
if $^O ne 'MSWin32' && $^O ne 'VMS';
# Windows handles blocking differently
#
# http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
# http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
#
# 0x8004667e is FIONBIO
#
# which is used to set blocking behaviour.
# NOTE:
# This is a little confusing, the perl keyword for this is
# 'blocking' but the OS level behaviour is 'non-blocking', probably
# because sockets are blocking by default.
# Therefore internally we have to reverse the semantics.
my $orig= !${*$sock}{io_sock_nonblocking};
return $orig unless @_;
my $block = shift;
if ( !$block != !$orig ) {
${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
or return undef;
}
return $orig;
}
sub close {
@_ == 1 or croak 'usage: $sock->close()';
my $sock = shift;
${*$sock}{'io_socket_peername'} = undef;
$sock->SUPER::close();
}
sub bind {
@_ == 2 or croak 'usage: $sock->bind(NAME)';
my $sock = shift;
my $addr = shift;
return bind($sock, $addr) ? $sock
: undef;
}
sub listen {
@_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
my($sock,$queue) = @_;
$queue = 5
unless $queue && $queue > 0;
return listen($sock, $queue) ? $sock
: undef;
}
sub accept {
@_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
my $sock = shift;
my $pkg = shift || $sock;
my $timeout = ${*$sock}{'io_socket_timeout'};
my $new = $pkg->new(Timeout => $timeout);
my $peer = undef;
if(defined $timeout) {
require IO::Select;
my $sel = new IO::Select $sock;
unless ($sel->can_read($timeout)) {
$@ = 'accept: timeout';
$! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
return;
}
}
$peer = accept($new,$sock)
or return;
${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
return wantarray ? ($new, $peer)
: $new;
}
sub sockname {
@_ == 1 or croak 'usage: $sock->sockname()';
getsockname($_[0]);
}
sub peername {
@_ == 1 or croak 'usage: $sock->peername()';
my($sock) = @_;
${*$sock}{'io_socket_peername'} ||= getpeername($sock);
}
sub connected {
@_ == 1 or croak 'usage: $sock->connected()';
my($sock) = @_;
getpeername($sock);
}
sub send {
@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
my $sock = $_[0];
my $flags = $_[2] || 0;
my $peer = $_[3] || $sock->peername;
croak 'send: Cannot determine peer address'
unless(defined $peer);
my $r = defined(getpeername($sock))
? send($sock, $_[1], $flags)
: send($sock, $_[1], $flags, $peer);
# remember who we send to, if it was successful
${*$sock}{'io_socket_peername'} = $peer
if(@_ == 4 && defined $r);
$r;
}
sub recv {
@_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
my $sock = $_[0];
my $len = $_[2];
my $flags = $_[3] || 0;
# remember who we recv'd from
${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}
sub shutdown {
@_ == 2 or croak 'usage: $sock->shutdown(HOW)';
my($sock, $how) = @_;
${*$sock}{'io_socket_peername'} = undef;
shutdown($sock, $how);
}
sub setsockopt {
@_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
setsockopt($_[0],$_[1],$_[2],$_[3]);
}
my $intsize = length(pack("i",0));
sub getsockopt {
@_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
my $r = getsockopt($_[0],$_[1],$_[2]);
# Just a guess
$r = unpack("i", $r)
if(defined $r && length($r) == $intsize);
$r;
}
sub sockopt {
my $sock = shift;
@_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
: $sock->setsockopt(SOL_SOCKET,@_);
}
sub atmark {
@_ == 1 or croak 'usage: $sock->atmark()';
my($sock) = @_;
sockatmark($sock);
}
sub timeout {
@_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
my($sock,$val) = @_;
my $r = ${*$sock}{'io_socket_timeout'};
${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
if(@_ == 2);
$r;
}
sub sockdomain {
@_ == 1 or croak 'usage: $sock->sockdomain()';
my $sock = shift;
if (!defined(${*$sock}{'io_socket_domain'})) {
my $addr = $sock->sockname();
${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
if (defined($addr));
}
${*$sock}{'io_socket_domain'};
}
sub socktype {
@_ == 1 or croak 'usage: $sock->socktype()';
my $sock = shift;
${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
${*$sock}{'io_socket_type'}
}
sub protocol {
@_ == 1 or croak 'usage: $sock->protocol()';
my($sock) = @_;
${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
${*$sock}{'io_socket_proto'};
}
1;
__END__

311
vendor/LeOS/tools-leos/common/perl-base/IO/Socket/INET.pm vendored
View File

@ -1,311 +0,0 @@
# IO::Socket::INET.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket::INET;
use strict;
our(@ISA, $VERSION);
use IO::Socket;
use Socket;
use Carp;
use Exporter;
use Errno;
@ISA = qw(IO::Socket);
$VERSION = "1.35";
my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
IO::Socket::INET->register_domain( AF_INET );
my %socket_type = ( tcp => SOCK_STREAM,
udp => SOCK_DGRAM,
icmp => SOCK_RAW
);
my %proto_number;
$proto_number{tcp} = Socket::IPPROTO_TCP() if defined &Socket::IPPROTO_TCP;
$proto_number{udp} = Socket::IPPROTO_UDP() if defined &Socket::IPPROTO_UDP;
$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
my %proto_name = reverse %proto_number;
sub new {
my $class = shift;
unshift(@_, "PeerAddr") if @_ == 1;
return $class->SUPER::new(@_);
}
sub _cache_proto {
my @proto = @_;
for (map lc($_), $proto[0], split(' ', $proto[1])) {
$proto_number{$_} = $proto[2];
}
$proto_name{$proto[2]} = $proto[0];
}
sub _get_proto_number {
my $name = lc(shift);
return undef unless defined $name;
return $proto_number{$name} if exists $proto_number{$name};
my @proto = eval { getprotobyname($name) };
return undef unless @proto;
_cache_proto(@proto);
return $proto[2];
}
sub _get_proto_name {
my $num = shift;
return undef unless defined $num;
return $proto_name{$num} if exists $proto_name{$num};
my @proto = eval { getprotobynumber($num) };
return undef unless @proto;
_cache_proto(@proto);
return $proto[0];
}
sub _sock_info {
my($addr,$port,$proto) = @_;
my $origport = $port;
my @serv = ();
$port = $1
if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
if(defined $proto && $proto =~ /\D/) {
my $num = _get_proto_number($proto);
unless (defined $num) {
$@ = "Bad protocol '$proto'";
return;
}
$proto = $num;
}
if(defined $port) {
my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
my $pnum = ($port =~ m,^(\d+)$,)[0];
@serv = getservbyname($port, _get_proto_name($proto) || "")
if ($port =~ m,\D,);
$port = $serv[2] || $defport || $pnum;
unless (defined $port) {
$@ = "Bad service '$origport'";
return;
}
$proto = _get_proto_number($serv[3]) if @serv && !$proto;
}
return ($addr || undef,
$port || undef,
$proto || undef
);
}
sub _error {
my $sock = shift;
my $err = shift;
{
local($!);
my $title = ref($sock).": ";
$@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
$sock->close()
if(defined fileno($sock));
}
$! = $err;
return undef;
}
sub _get_addr {
my($sock,$addr_str, $multi) = @_;
my @addr;
if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
(undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
} else {
my $h = inet_aton($addr_str);
push(@addr, $h) if defined $h;
}
@addr;
}
sub configure {
my($sock,$arg) = @_;
my($lport,$rport,$laddr,$raddr,$proto,$type);
$arg->{LocalAddr} = $arg->{LocalHost}
if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
$arg->{LocalPort},
$arg->{Proto})
or return _error($sock, $!, $@);
$laddr = defined $laddr ? inet_aton($laddr)
: INADDR_ANY;
return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
unless(defined $laddr);
$arg->{PeerAddr} = $arg->{PeerHost}
if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
unless(exists $arg->{Listen}) {
($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
$arg->{PeerPort},
$proto)
or return _error($sock, $!, $@);
}
$proto ||= _get_proto_number('tcp');
$type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)};
my @raddr = ();
if(defined $raddr) {
@raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
unless @raddr;
}
while(1) {
$sock->socket(AF_INET, $type, $proto) or
return _error($sock, $!, "$!");
if (defined $arg->{Blocking}) {
defined $sock->blocking($arg->{Blocking})
or return _error($sock, $!, "$!");
}
if ($arg->{Reuse} || $arg->{ReuseAddr}) {
$sock->sockopt(SO_REUSEADDR,1) or
return _error($sock, $!, "$!");
}
if ($arg->{ReusePort}) {
$sock->sockopt(SO_REUSEPORT,1) or
return _error($sock, $!, "$!");
}
if ($arg->{Broadcast}) {
$sock->sockopt(SO_BROADCAST,1) or
return _error($sock, $!, "$!");
}
if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
$sock->bind($lport || 0, $laddr) or
return _error($sock, $!, "$!");
}
if(exists $arg->{Listen}) {
$sock->listen($arg->{Listen} || 5) or
return _error($sock, $!, "$!");
last;
}
# don't try to connect unless we're given a PeerAddr
last unless exists($arg->{PeerAddr});
$raddr = shift @raddr;
return _error($sock, $EINVAL, 'Cannot determine remote port')
unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
last
unless($type == SOCK_STREAM || defined $raddr);
return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
unless defined $raddr;
# my $timeout = ${*$sock}{'io_socket_timeout'};
# my $before = time() if $timeout;
undef $@;
if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
# ${*$sock}{'io_socket_timeout'} = $timeout;
return $sock;
}
return _error($sock, $!, $@ || "Timeout")
unless @raddr;
# if ($timeout) {
# my $new_timeout = $timeout - (time() - $before);
# return _error($sock,
# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
# "Timeout") if $new_timeout <= 0;
# ${*$sock}{'io_socket_timeout'} = $new_timeout;
# }
}
$sock;
}
sub connect {
@_ == 2 || @_ == 3 or
croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
my $sock = shift;
return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
}
sub bind {
@_ == 2 || @_ == 3 or
croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
my $sock = shift;
return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
}
sub sockaddr {
@_ == 1 or croak 'usage: $sock->sockaddr()';
my($sock) = @_;
my $name = $sock->sockname;
$name ? (sockaddr_in($name))[1] : undef;
}
sub sockport {
@_ == 1 or croak 'usage: $sock->sockport()';
my($sock) = @_;
my $name = $sock->sockname;
$name ? (sockaddr_in($name))[0] : undef;
}
sub sockhost {
@_ == 1 or croak 'usage: $sock->sockhost()';
my($sock) = @_;
my $addr = $sock->sockaddr;
$addr ? inet_ntoa($addr) : undef;
}
sub peeraddr {
@_ == 1 or croak 'usage: $sock->peeraddr()';
my($sock) = @_;
my $name = $sock->peername;
$name ? (sockaddr_in($name))[1] : undef;
}
sub peerport {
@_ == 1 or croak 'usage: $sock->peerport()';
my($sock) = @_;
my $name = $sock->peername;
$name ? (sockaddr_in($name))[0] : undef;
}
sub peerhost {
@_ == 1 or croak 'usage: $sock->peerhost()';
my($sock) = @_;
my $addr = $sock->peeraddr;
$addr ? inet_ntoa($addr) : undef;
}
1;
__END__

692
vendor/LeOS/tools-leos/common/perl-base/IO/Socket/IP.pm vendored
View File

@ -1,692 +0,0 @@
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License (the same terms as Perl itself)
#
# (C) Paul Evans, 2010-2015 -- leonerd@leonerd.org.uk
package IO::Socket::IP;
# $VERSION needs to be set before use base 'IO::Socket'
# - https://rt.cpan.org/Ticket/Display.html?id=92107
BEGIN {
$VERSION = '0.38';
}
use strict;
use warnings;
use base qw( IO::Socket );
use Carp;
use Socket 1.97 qw(
getaddrinfo getnameinfo
sockaddr_family
AF_INET
AI_PASSIVE
IPPROTO_TCP IPPROTO_UDP
IPPROTO_IPV6 IPV6_V6ONLY
NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV NIx_NOHOST NIx_NOSERV
SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR
SOCK_DGRAM SOCK_STREAM
SOL_SOCKET
);
my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined
my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0;
use POSIX qw( dup2 );
use Errno qw( EINVAL EINPROGRESS EISCONN ENOTCONN ETIMEDOUT EWOULDBLOCK );
use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );
# At least one OS (Android) is known not to have getprotobyname()
use constant HAVE_GETPROTOBYNAME => defined eval { getprotobyname( "tcp" ) };
my $IPv6_re = do {
# translation of RFC 3986 3.2.2 ABNF to re
my $IPv4address = do {
my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>;
qq<$dec_octet(?: \\. $dec_octet){3}>;
};
my $IPv6address = do {
my $h16 = qq<[0-9A-Fa-f]{1,4}>;
my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>;
qq<(?:
(?: $h16 : ){6} $ls32
| :: (?: $h16 : ){5} $ls32
| (?: $h16 )? :: (?: $h16 : ){4} $ls32
| (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
| (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
| (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32
| (?: (?: $h16 : ){0,4} $h16 )? :: $ls32
| (?: (?: $h16 : ){0,5} $h16 )? :: $h16
| (?: (?: $h16 : ){0,6} $h16 )? ::
)>
};
qr<$IPv6address>xo;
};
sub import
{
my $pkg = shift;
my @symbols;
foreach ( @_ ) {
if( $_ eq "-register" ) {
IO::Socket::IP::_ForINET->register_domain( AF_INET );
IO::Socket::IP::_ForINET6->register_domain( $AF_INET6 ) if defined $AF_INET6;
}
else {
push @symbols, $_;
}
}
@_ = ( $pkg, @symbols );
goto &IO::Socket::import;
}
# Convenient capability test function
{
my $can_disable_v6only;
sub CAN_DISABLE_V6ONLY
{
return $can_disable_v6only if defined $can_disable_v6only;
socket my $testsock, Socket::PF_INET6(), SOCK_STREAM, 0 or
die "Cannot socket(PF_INET6) - $!";
if( setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 ) {
return $can_disable_v6only = 1;
}
elsif( $! == EINVAL ) {
return $can_disable_v6only = 0;
}
else {
die "Cannot setsockopt() - $!";
}
}
}
sub new
{
my $class = shift;
my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
return $class->SUPER::new(%arg);
}
# IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
# before calling our real _configure method
sub configure
{
my $self = shift;
my ( $arg ) = @_;
$arg->{PeerHost} = delete $arg->{PeerAddr}
if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};
$arg->{PeerService} = delete $arg->{PeerPort}
if exists $arg->{PeerPort} && !exists $arg->{PeerService};
$arg->{LocalHost} = delete $arg->{LocalAddr}
if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};
$arg->{LocalService} = delete $arg->{LocalPort}
if exists $arg->{LocalPort} && !exists $arg->{LocalService};
for my $type (qw(Peer Local)) {
my $host = $type . 'Host';
my $service = $type . 'Service';
if( defined $arg->{$host} ) {
( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} );
# IO::Socket::INET compat - *Host parsed port always takes precedence
$arg->{$service} = $s if defined $s;
}
}
$self->_io_socket_ip__configure( $arg );
}
# Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that
sub _io_socket_ip__configure
{
my $self = shift;
my ( $arg ) = @_;
my %hints;
my @localinfos;
my @peerinfos;
my $listenqueue = $arg->{Listen};
if( defined $listenqueue and
( defined $arg->{PeerHost} || defined $arg->{PeerService} || defined $arg->{PeerAddrInfo} ) ) {
croak "Cannot Listen with a peer address";
}
if( defined $arg->{GetAddrInfoFlags} ) {
$hints{flags} = $arg->{GetAddrInfoFlags};
}
else {
$hints{flags} = $AI_ADDRCONFIG;
}
if( defined( my $family = $arg->{Family} ) ) {
$hints{family} = $family;
}
if( defined( my $type = $arg->{Type} ) ) {
$hints{socktype} = $type;
}
if( defined( my $proto = $arg->{Proto} ) ) {
unless( $proto =~ m/^\d+$/ ) {
my $protonum = HAVE_GETPROTOBYNAME
? getprotobyname( $proto )
: eval { Socket->${\"IPPROTO_\U$proto"}() };
defined $protonum or croak "Unrecognised protocol $proto";
$proto = $protonum;
}
$hints{protocol} = $proto;
}
# To maintain compatibility with IO::Socket::INET, imply a default of
# SOCK_STREAM + IPPROTO_TCP if neither hint is given
if( !defined $hints{socktype} and !defined $hints{protocol} ) {
$hints{socktype} = SOCK_STREAM;
$hints{protocol} = IPPROTO_TCP;
}
# Some OSes (NetBSD) don't seem to like just a protocol hint without a
# socktype hint as well. We'll set a couple of common ones
if( !defined $hints{socktype} and defined $hints{protocol} ) {
$hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
$hints{socktype} = SOCK_DGRAM if $hints{protocol} == IPPROTO_UDP;
}
if( my $info = $arg->{LocalAddrInfo} ) {
ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
@localinfos = @$info;
}
elsif( defined $arg->{LocalHost} or
defined $arg->{LocalService} or
HAVE_MSWIN32 and $arg->{Listen} ) {
# Either may be undef
my $host = $arg->{LocalHost};
my $service = $arg->{LocalService};
unless ( defined $host or defined $service ) {
$service = 0;
}
local $1; # Placate a taint-related bug; [perl #67962]
defined $service and $service =~ s/\((\d+)\)$// and
my $fallback_port = $1;
my %localhints = %hints;
$localhints{flags} |= AI_PASSIVE;
( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );
if( $err and defined $fallback_port ) {
( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
}
if( $err ) {
$@ = "$err";
$! = EINVAL;
return;
}
}
if( my $info = $arg->{PeerAddrInfo} ) {
ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
@peerinfos = @$info;
}
elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
defined( my $host = $arg->{PeerHost} ) or
croak "Expected 'PeerHost'";
defined( my $service = $arg->{PeerService} ) or
croak "Expected 'PeerService'";
local $1; # Placate a taint-related bug; [perl #67962]
defined $service and $service =~ s/\((\d+)\)$// and
my $fallback_port = $1;
( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );
if( $err and defined $fallback_port ) {
( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
}
if( $err ) {
$@ = "$err";
$! = EINVAL;
return;
}
}
my $INT_1 = pack "i", 1;
my @sockopts_enabled;
push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEADDR, $INT_1 ] if $arg->{ReuseAddr};
push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEPORT, $INT_1 ] if $arg->{ReusePort};
push @sockopts_enabled, [ SOL_SOCKET, SO_BROADCAST, $INT_1 ] if $arg->{Broadcast};
if( my $sockopts = $arg->{Sockopts} ) {
ref $sockopts eq "ARRAY" or croak "Expected 'Sockopts' to be an ARRAY ref";
foreach ( @$sockopts ) {
ref $_ eq "ARRAY" or croak "Bad Sockopts item - expected ARRAYref";
@$_ >= 2 and @$_ <= 3 or
croak "Bad Sockopts item - expected 2 or 3 elements";
my ( $level, $optname, $value ) = @$_;
# TODO: consider more sanity checking on argument values
defined $value or $value = $INT_1;
push @sockopts_enabled, [ $level, $optname, $value ];
}
}
my $blocking = $arg->{Blocking};
defined $blocking or $blocking = 1;
my $v6only = $arg->{V6Only};
# IO::Socket::INET defines this key. IO::Socket::IP always implements the
# behaviour it requests, so we can ignore it, unless the caller is for some
# reason asking to disable it.
if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) {
croak "Cannot disable the MultiHomed parameter";
}
my @infos;
foreach my $local ( @localinfos ? @localinfos : {} ) {
foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
next if defined $local->{family} and defined $peer->{family} and
$local->{family} != $peer->{family};
next if defined $local->{socktype} and defined $peer->{socktype} and
$local->{socktype} != $peer->{socktype};
next if defined $local->{protocol} and defined $peer->{protocol} and
$local->{protocol} != $peer->{protocol};
my $family = $local->{family} || $peer->{family} or next;
my $socktype = $local->{socktype} || $peer->{socktype} or next;
my $protocol = $local->{protocol} || $peer->{protocol} || 0;
push @infos, {
family => $family,
socktype => $socktype,
protocol => $protocol,
localaddr => $local->{addr},
peeraddr => $peer->{addr},
};
}
}
if( !@infos ) {
# If there was a Family hint then create a plain unbound, unconnected socket
if( defined $hints{family} ) {
@infos = ( {
family => $hints{family},
socktype => $hints{socktype},
protocol => $hints{protocol},
} );
}
# If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
# suitable family first.
else {
( my $err, @infos ) = getaddrinfo( "", "0", \%hints );
if( $err ) {
$@ = "$err";
$! = EINVAL;
return;
}
# We'll take all the @infos anyway, because some OSes (HPUX) are known to
# ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't
# support them
}
}
# In the nonblocking case, caller will be calling ->setup multiple times.
# Store configuration in the object for the ->setup method
# Yes, these are messy. Sorry, I can't help that...
${*$self}{io_socket_ip_infos} = \@infos;
${*$self}{io_socket_ip_idx} = -1;
${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
${*$self}{io_socket_ip_v6only} = $v6only;
${*$self}{io_socket_ip_listenqueue} = $listenqueue;
${*$self}{io_socket_ip_blocking} = $blocking;
${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];
# ->setup is allowed to return false in nonblocking mode
$self->setup or !$blocking or return undef;
return $self;
}
sub setup
{
my $self = shift;
while(1) {
${*$self}{io_socket_ip_idx}++;
last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} };
my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}];
$self->socket( @{$info}{qw( family socktype protocol )} ) or
( ${*$self}{io_socket_ip_errors}[2] = $!, next );
$self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};
foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
my ( $level, $optname, $value ) = @$sockopt;
$self->setsockopt( $level, $optname, $value ) or ( $@ = "$!", return undef );
}
if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) {
my $v6only = ${*$self}{io_socket_ip_v6only};
$self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
}
if( defined( my $addr = $info->{localaddr} ) ) {
$self->bind( $addr ) or
( ${*$self}{io_socket_ip_errors}[1] = $!, next );
}
if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
$self->listen( $listenqueue ) or ( $@ = "$!", return undef );
}
if( defined( my $addr = $info->{peeraddr} ) ) {
if( $self->connect( $addr ) ) {
$! = 0;
return 1;
}
if( $! == EINPROGRESS or $! == EWOULDBLOCK ) {
${*$self}{io_socket_ip_connect_in_progress} = 1;
return 0;
}
# If connect failed but we have no system error there must be an error
# at the application layer, like a bad certificate with
# IO::Socket::SSL.
# In this case don't continue IP based multi-homing because the problem
# cannot be solved at the IP layer.
return 0 if ! $!;
${*$self}{io_socket_ip_errors}[0] = $!;
next;
}
return 1;
}
# Pick the most appropriate error, stringified
$! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
$@ = "$!";
return undef;
}
sub connect :method
{
my $self = shift;
# It seems that IO::Socket hides EINPROGRESS errors, making them look like
# a success. This is annoying here.
# Instead of putting up with its frankly-irritating intentional breakage of
# useful APIs I'm just going to end-run around it and call core's connect()
# directly
if( @_ ) {
my ( $addr ) = @_;
# Annoyingly IO::Socket's connect() is where the timeout logic is
# implemented, so we'll have to reinvent it here
my $timeout = ${*$self}{'io_socket_timeout'};
return connect( $self, $addr ) unless defined $timeout;
my $was_blocking = $self->blocking( 0 );
my $err = defined connect( $self, $addr ) ? 0 : $!+0;
if( !$err ) {
# All happy
$self->blocking( $was_blocking );
return 1;
}
elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) {
# Failed for some other reason
$self->blocking( $was_blocking );
return undef;
}
elsif( !$was_blocking ) {
# We shouldn't block anyway
return undef;
}
my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1;
if( !select( undef, $vec, $vec, $timeout ) ) {
$self->blocking( $was_blocking );
$! = ETIMEDOUT;
return undef;
}
# Hoist the error by connect()ing a second time
$err = $self->getsockopt( SOL_SOCKET, SO_ERROR );
$err = 0 if $err == EISCONN; # Some OSes give EISCONN
$self->blocking( $was_blocking );
$! = $err, return undef if $err;
return 1;
}
return 1 if !${*$self}{io_socket_ip_connect_in_progress};
# See if a connect attempt has just failed with an error
if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
delete ${*$self}{io_socket_ip_connect_in_progress};
${*$self}{io_socket_ip_errors}[0] = $! = $errno;
return $self->setup;
}
# No error, so either connect is still in progress, or has completed
# successfully. We can tell by trying to connect() again; either it will
# succeed or we'll get EISCONN (connected successfully), or EALREADY
# (still in progress). This even works on MSWin32.
my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr};
if( connect( $self, $addr ) or $! == EISCONN ) {
delete ${*$self}{io_socket_ip_connect_in_progress};
$! = 0;
return 1;
}
else {
$! = EINPROGRESS;
return 0;
}
}
sub connected
{
my $self = shift;
return defined $self->fileno &&
!${*$self}{io_socket_ip_connect_in_progress} &&
defined getpeername( $self ); # ->peername caches, we need to detect disconnection
}
sub _get_host_service
{
my $self = shift;
my ( $addr, $flags, $xflags ) = @_;
defined $addr or
$! = ENOTCONN, return;
$flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM;
my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 );
croak "getnameinfo - $err" if $err;
return ( $host, $service );
}
sub _unpack_sockaddr
{
my ( $addr ) = @_;
my $family = sockaddr_family $addr;
if( $family == AF_INET ) {
return ( Socket::unpack_sockaddr_in( $addr ) )[1];
}
elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
}
else {
croak "Unrecognised address family $family";
}
}
sub sockhost_service
{
my $self = shift;
my ( $numeric ) = @_;
$self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
}
sub sockhost { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
sub sockport { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
sub sockhostname { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] }
sub sockservice { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] }
sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }
sub peerhost_service
{
my $self = shift;
my ( $numeric ) = @_;
$self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
}
sub peerhost { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
sub peerport { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
sub peerhostname { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] }
sub peerservice { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] }
sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }
# This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
# it
# https://rt.cpan.org/Ticket/Display.html?id=61577
sub accept
{
my $self = shift;
my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;
${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
return wantarray ? ( $new, $peer )
: $new;
}
# This second unbelievably dodgy hack guarantees that $self->fileno doesn't
# change, which is useful during nonblocking connect
sub socket :method
{
my $self = shift;
return $self->SUPER::socket(@_) if not defined $self->fileno;
# I hate core prototypes sometimes...
socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;
dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
}
# Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an
# ->fdopen call. In this case we'll apply a fix
BEGIN {
if( eval($IO::Socket::VERSION) < 1.35 ) {
*socktype = sub {
my $self = shift;
my $type = $self->SUPER::socktype;
if( !defined $type ) {
$type = $self->sockopt( Socket::SO_TYPE() );
}
return $type;
};
}
}
sub as_inet
{
my $self = shift;
croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
}
sub split_addr
{
shift;
my ( $addr ) = @_;
local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
$addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) {
return ( $1, $2 ) if defined $2 and length $2;
return ( $1, undef );
}
return ( $addr, undef );
}
sub join_addr
{
shift;
my ( $host, $port ) = @_;
$host = "[$host]" if $host =~ m/:/;
return join ":", $host, $port if defined $port;
return $host;
}
# Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
# before calling ->configure, we need to keep track of which it was
package # hide from indexer
IO::Socket::IP::_ForINET;
use base qw( IO::Socket::IP );
sub configure
{
# This is evil
my $self = shift;
my ( $arg ) = @_;
bless $self, "IO::Socket::IP";
$self->configure( { %$arg, Family => Socket::AF_INET() } );
}
package # hide from indexer
IO::Socket::IP::_ForINET6;
use base qw( IO::Socket::IP );
sub configure
{
# This is evil
my $self = shift;
my ( $arg ) = @_;
bless $self, "IO::Socket::IP";
$self->configure( { %$arg, Family => Socket::AF_INET6() } );
}
0x55AA;

68
vendor/LeOS/tools-leos/common/perl-base/IO/Socket/UNIX.pm vendored
View File

@ -1,68 +0,0 @@
# IO::Socket::UNIX.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket::UNIX;
use strict;
our(@ISA, $VERSION);
use IO::Socket;
use Carp;
@ISA = qw(IO::Socket);
$VERSION = "1.26";
$VERSION = eval $VERSION;
IO::Socket::UNIX->register_domain( AF_UNIX );
sub new {
my $class = shift;
unshift(@_, "Peer") if @_ == 1;
return $class->SUPER::new(@_);
}
sub configure {
my($sock,$arg) = @_;
my($bport,$cport);
my $type = $arg->{Type} || SOCK_STREAM;
$sock->socket(AF_UNIX, $type, 0) or
return undef;
if(exists $arg->{Local}) {
my $addr = sockaddr_un($arg->{Local});
$sock->bind($addr) or
return undef;
}
if(exists $arg->{Listen} && $type != SOCK_DGRAM) {
$sock->listen($arg->{Listen} || 5) or
return undef;
}
elsif(exists $arg->{Peer}) {
my $addr = sockaddr_un($arg->{Peer});
$sock->connect($addr) or
return undef;
}
$sock;
}
sub hostpath {
@_ == 1 or croak 'usage: $sock->hostpath()';
my $n = $_[0]->sockname || return undef;
(sockaddr_un($n))[0];
}
sub peerpath {
@_ == 1 or croak 'usage: $sock->peerpath()';
my $n = $_[0]->peername || return undef;
(sockaddr_un($n))[0];
}
1; # Keep require happy
__END__

38
vendor/LeOS/tools-leos/common/perl-base/IPC/Open2.pm vendored
View File

@ -1,38 +0,0 @@
package IPC::Open2;
use strict;
our ($VERSION, @ISA, @EXPORT);
require 5.000;
require Exporter;
$VERSION = 1.04;
@ISA = qw(Exporter);
@EXPORT = qw(open2);
# &open2: tom christiansen, <tchrist@convex.com>
#
# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
#
# spawn the given $cmd and connect $rdr for
# reading and $wtr for writing. return pid
# of child, or 0 on failure.
#
# WARNING: this is dangerous, as you may block forever
# unless you are very careful.
#
# $wtr is left unbuffered.
#
# abort program if
# rdr or wtr are null
# a system call fails
require IPC::Open3;
sub open2 {
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
return IPC::Open3::_open3('open2', $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
}
1

330
vendor/LeOS/tools-leos/common/perl-base/IPC/Open3.pm vendored
View File

@ -1,330 +0,0 @@
package IPC::Open3;
use strict;
no strict 'refs'; # because users pass me bareword filehandles
our ($VERSION, @ISA, @EXPORT);
require Exporter;
use Carp;
use Symbol qw(gensym qualify);
$VERSION = '1.20';
@ISA = qw(Exporter);
@EXPORT = qw(open3);
# &open3: Marc Horowitz <marc@mit.edu>
# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
# fixed for autovivving FHs, tchrist again
# allow fd numbers to be used, by Frank Tobin
# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
#
# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
#
# spawn the given $cmd and connect rdr for
# reading, wtr for writing, and err for errors.
# if err is '', or the same as rdr, then stdout and
# stderr of the child are on the same fh. returns pid
# of child (or dies on failure).
# if wtr begins with '<&', then wtr will be closed in the parent, and
# the child will read from it directly. if rdr or err begins with
# '>&', then the child will send output directly to that fd. In both
# cases, there will be a dup() instead of a pipe() made.
# WARNING: this is dangerous, as you may block forever
# unless you are very careful.
#
# $wtr is left unbuffered.
#
# abort program if
# rdr or wtr are null
# a system call fails
our $Me = 'open3 (bug)'; # you should never see this, it's always localized
# Fatal.pm needs to be fixed WRT prototypes.
sub xpipe {
pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
}
# I tried using a * prototype character for the filehandle but it still
# disallows a bareword while compiling under strict subs.
sub xopen {
open $_[0], $_[1], @_[2..$#_] and return;
local $" = ', ';
carp "$Me: open(@_) failed: $!";
}
sub xclose {
$_[0] =~ /\A=?(\d+)\z/
? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); }
: close $_[0]
or croak "$Me: close($_[0]) failed: $!";
}
sub xfileno {
return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
return fileno $_[0];
}
use constant FORCE_DEBUG_SPAWN => 0;
use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
sub _open3 {
local $Me = shift;
# simulate autovivification of filehandles because
# it's too ugly to use @_ throughout to make perl do it for us
# tchrist 5-Mar-00
# Historically, open3(undef...) has silently worked, so keep
# it working.
splice @_, 0, 1, undef if \$_[0] == \undef;
splice @_, 1, 1, undef if \$_[1] == \undef;
unless (eval {
$_[0] = gensym unless defined $_[0] && length $_[0];
$_[1] = gensym unless defined $_[1] && length $_[1];
1; })
{
# must strip crud for croak to add back, or looks ugly
$@ =~ s/(?<=value attempted) at .*//s;
croak "$Me: $@";
}
my @handles = ({ mode => '<', handle => \*STDIN },
{ mode => '>', handle => \*STDOUT },
{ mode => '>', handle => \*STDERR },
);
foreach (@handles) {
$_->{parent} = shift;
$_->{open_as} = gensym;
}
if (@_ > 1 and $_[0] eq '-') {
croak "Arguments don't make sense when the command is '-'"
}
$handles[2]{parent} ||= $handles[1]{parent};
$handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
my $package;
foreach (@handles) {
$_->{dup} = ($_->{parent} =~ s/^[<>]&//);
if ($_->{parent} !~ /\A=?(\d+)\z/) {
# force unqualified filehandles into caller's package
$package //= caller 1;
$_->{parent} = qualify $_->{parent}, $package;
}
next if $_->{dup} or $_->{dup_of_out};
if ($_->{mode} eq '<') {
xpipe $_->{open_as}, $_->{parent};
} else {
xpipe $_->{parent}, $_->{open_as};
}
}
my $kidpid;
if (!DO_SPAWN) {
# Used to communicate exec failures.
xpipe my $stat_r, my $stat_w;
$kidpid = fork;
croak "$Me: fork failed: $!" unless defined $kidpid;
if ($kidpid == 0) { # Kid
eval {
# A tie in the parent should not be allowed to cause problems.
untie *STDIN;
untie *STDOUT;
untie *STDERR;
close $stat_r;
require Fcntl;
my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
croak "$Me: fcntl failed: $!" unless $flags;
fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
or croak "$Me: fcntl failed: $!";
# If she wants to dup the kid's stderr onto her stdout I need to
# save a copy of her stdout before I put something else there.
if (!$handles[2]{dup_of_out} && $handles[2]{dup}
&& xfileno($handles[2]{parent}) == fileno \*STDOUT) {
my $tmp = gensym;
xopen($tmp, '>&', $handles[2]{parent});
$handles[2]{parent} = $tmp;
}
foreach (@handles) {
if ($_->{dup_of_out}) {
xopen \*STDERR, ">&STDOUT"
if defined fileno STDERR && fileno STDERR != fileno STDOUT;
} elsif ($_->{dup}) {
xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
if fileno $_->{handle} != xfileno($_->{parent});
} else {
xclose $_->{parent}, $_->{mode};
xopen $_->{handle}, $_->{mode} . '&=',
fileno $_->{open_as};
}
}
return 1 if ($_[0] eq '-');
exec @_ or do {
local($")=(" ");
croak "$Me: exec of @_ failed: $!";
};
} and do {
close $stat_w;
return 0;
};
my $bang = 0+$!;
my $err = $@;
utf8::encode $err if $] >= 5.008;
print $stat_w pack('IIa*', $bang, length($err), $err);
close $stat_w;
eval { require POSIX; POSIX::_exit(255); };
exit 255;
}
else { # Parent
close $stat_w;
my $to_read = length(pack('I', 0)) * 2;
my $bytes_read = read($stat_r, my $buf = '', $to_read);
if ($bytes_read) {
(my $bang, $to_read) = unpack('II', $buf);
read($stat_r, my $err = '', $to_read);
waitpid $kidpid, 0; # Reap child which should have exited
if ($err) {
utf8::decode $err if $] >= 5.008;
} else {
$err = "$Me: " . ($! = $bang);
}
$! = $bang;
die($err);
}
}
}
else { # DO_SPAWN
# All the bookkeeping of coincidence between handles is
# handled in spawn_with_handles.
my @close;
foreach (@handles) {
if ($_->{dup_of_out}) {
$_->{open_as} = $handles[1]{open_as};
} elsif ($_->{dup}) {
$_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
? $_->{parent} : \*{$_->{parent}};
push @close, $_->{open_as};
} else {
push @close, \*{$_->{parent}}, $_->{open_as};
}
}
require IO::Pipe;
$kidpid = eval {
spawn_with_handles(\@handles, \@close, @_);
};
die "$Me: $@" if $@;
}
foreach (@handles) {
next if $_->{dup} or $_->{dup_of_out};
xclose $_->{open_as}, $_->{mode};
}
# If the write handle is a dup give it away entirely, close my copy
# of it.
xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
$kidpid;
}
sub open3 {
if (@_ < 4) {
local $" = ', ';
croak "open3(@_): not enough arguments";
}
return _open3 'open3', @_
}
sub spawn_with_handles {
my $fds = shift; # Fields: handle, mode, open_as
my $close_in_child = shift;
my ($fd, %saved, @errs);
foreach $fd (@$fds) {
$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
$saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
}
foreach $fd (@$fds) {
bless $fd->{handle}, 'IO::Handle'
unless eval { $fd->{handle}->isa('IO::Handle') } ;
# If some of handles to redirect-to coincide with handles to
# redirect, we need to use saved variants:
my $open_as = $fd->{open_as};
my $fileno = fileno($open_as);
$fd->{handle}->fdopen(defined($fileno)
? $saved{$fileno} || $open_as
: $open_as,
$fd->{mode});
}
unless ($^O eq 'MSWin32') {
require Fcntl;
# Stderr may be redirected below, so we save the err text:
foreach $fd (@$close_in_child) {
next unless fileno $fd;
fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
unless $saved{fileno $fd}; # Do not close what we redirect!
}
}
my $pid;
unless (@errs) {
if (FORCE_DEBUG_SPAWN) {
pipe my $r, my $w or die "Pipe failed: $!";
$pid = fork;
die "Fork failed: $!" unless defined $pid;
if (!$pid) {
{ no warnings; exec @_ }
print $w 0 + $!;
close $w;
require POSIX;
POSIX::_exit(255);
}
close $w;
my $bad = <$r>;
if (defined $bad) {
$! = $bad;
undef $pid;
}
} else {
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
}
if($@) {
push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@";
} elsif(!$pid || $pid < 0) {
push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!";
}
}
# Do this in reverse, so that STDERR is restored first:
foreach $fd (reverse @$fds) {
$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
}
foreach (values %saved) {
$_->close or croak "Can't close: $!";
}
croak join "\n", @errs if @errs;
return $pid;
}
1; # so require is happy

42
vendor/LeOS/tools-leos/common/perl-base/List/Util.pm vendored
View File

@ -1,42 +0,0 @@
# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk>
package List::Util;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
);
our $VERSION = "1.46_02";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
require XSLoader;
XSLoader::load('List::Util', $XS_VERSION);
sub import
{
my $pkg = caller;
# (RT88848) Touch the caller's $a and $b, to avoid the warning of
# Name "main::a" used only once: possible typo" warning
no strict 'refs';
${"${pkg}::a"} = ${"${pkg}::a"};
${"${pkg}::b"} = ${"${pkg}::b"};
goto &Exporter::import;
}
# For objects returned by pairs()
sub List::Util::_Pair::key { shift->[0] }
sub List::Util::_Pair::value { shift->[1] }
1;

561
vendor/LeOS/tools-leos/common/perl-base/POSIX.pm vendored
View File

@ -1,561 +0,0 @@
package POSIX;
use strict;
use warnings;
our ($AUTOLOAD, %SIGRT);
our $VERSION = '1.76';
require XSLoader;
use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD
F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND
O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
O_WRONLY SEEK_CUR SEEK_END SEEK_SET
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID
S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR);
my $loaded;
sub croak { require Carp; goto &Carp::croak }
sub usage { croak "Usage: POSIX::$_[0]" }
XSLoader::load();
my %replacement = (
L_tmpnam => undef,
atexit => 'END {}',
atof => undef,
atoi => undef,
atol => undef,
bsearch => \'not supplied',
calloc => undef,
clearerr => 'IO::Handle::clearerr',
div => '/, % and int',
execl => undef,
execle => undef,
execlp => undef,
execv => undef,
execve => undef,
execvp => undef,
fclose => 'IO::Handle::close',
fdopen => 'IO::Handle::new_from_fd',
feof => 'IO::Handle::eof',
ferror => 'IO::Handle::error',
fflush => 'IO::Handle::flush',
fgetc => 'IO::Handle::getc',
fgetpos => 'IO::Seekable::getpos',
fgets => 'IO::Handle::gets',
fileno => 'IO::Handle::fileno',
fopen => 'IO::File::open',
fprintf => 'printf',
fputc => 'print',
fputs => 'print',
fread => 'read',
free => undef,
freopen => 'open',
fscanf => '<> and regular expressions',
fseek => 'IO::Seekable::seek',
fsetpos => 'IO::Seekable::setpos',
fsync => 'IO::Handle::sync',
ftell => 'IO::Seekable::tell',
fwrite => 'print',
labs => 'abs',
ldiv => '/, % and int',
longjmp => 'die',
malloc => undef,
memchr => 'index()',
memcmp => 'eq',
memcpy => '=',
memmove => '=',
memset => 'x',
offsetof => undef,
putc => 'print',
putchar => 'print',
puts => 'print',
qsort => 'sort',
rand => \'non-portable, use Perl\'s rand instead',
realloc => undef,
scanf => '<> and regular expressions',
setbuf => 'IO::Handle::setbuf',
setjmp => 'eval {}',
setvbuf => 'IO::Handle::setvbuf',
siglongjmp => 'die',
sigsetjmp => 'eval {}',
srand => \'not supplied; refer to Perl\'s srand documentation',
sscanf => 'regular expressions',
strcat => '.=',
strchr => 'index()',
strcmp => 'eq',
strcpy => '=',
strcspn => 'regular expressions',
strlen => 'length',
strncat => '.=',
strncmp => 'eq',
strncpy => '=',
strpbrk => undef,
strrchr => 'rindex()',
strspn => undef,
strtok => undef,
tmpfile => 'IO::File::new_tmpfile',
tmpnam => 'use File::Temp',
ungetc => 'IO::Handle::ungetc',
vfprintf => undef,
vprintf => undef,
vsprintf => undef,
);
my %reimpl = (
abs => 'x => CORE::abs($_[0])',
alarm => 'seconds => CORE::alarm($_[0])',
assert => 'expr => croak "Assertion failed" if !$_[0]',
atan2 => 'x, y => CORE::atan2($_[0], $_[1])',
chdir => 'directory => CORE::chdir($_[0])',
chmod => 'mode, filename => CORE::chmod($_[0], $_[1])',
chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])',
closedir => 'dirhandle => CORE::closedir($_[0])',
cos => 'x => CORE::cos($_[0])',
creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])',
errno => '$! + 0',
exit => 'status => CORE::exit($_[0])',
exp => 'x => CORE::exp($_[0])',
fabs => 'x => CORE::abs($_[0])',
fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])',
fork => 'CORE::fork',
fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross.
getc => 'handle => CORE::getc($_[0])',
getchar => 'CORE::getc(STDIN)',
getegid => '$) + 0',
getenv => 'name => $ENV{$_[0]}',
geteuid => '$> + 0',
getgid => '$( + 0',
getgrgid => 'gid => CORE::getgrgid($_[0])',
getgrnam => 'name => CORE::getgrnam($_[0])',
getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)',
getlogin => 'CORE::getlogin()',
getpgrp => 'CORE::getpgrp',
getpid => '$$',
getppid => 'CORE::getppid',
getpwnam => 'name => CORE::getpwnam($_[0])',
getpwuid => 'uid => CORE::getpwuid($_[0])',
gets => 'scalar <STDIN>',
getuid => '$<',
gmtime => 'time => CORE::gmtime($_[0])',
isatty => 'filehandle => -t $_[0]',
kill => 'pid, sig => CORE::kill $_[1], $_[0]',
link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])',
localtime => 'time => CORE::localtime($_[0])',
log => 'x => CORE::log($_[0])',
mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])',
opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef',
pow => 'x, exponent => $_[0] ** $_[1]',
raise => 'sig => CORE::kill $_[0], $$; # Is this good enough',
readdir => 'dirhandle => CORE::readdir($_[0])',
remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])',
rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])',
rewind => 'filehandle => CORE::seek($_[0],0,0)',
rewinddir => 'dirhandle => CORE::rewinddir($_[0])',
rmdir => 'directoryname => CORE::rmdir($_[0])',
sin => 'x => CORE::sin($_[0])',
sqrt => 'x => CORE::sqrt($_[0])',
stat => 'filename => CORE::stat($_[0])',
strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"',
strstr => 'big, little => CORE::index($_[0], $_[1])',
system => 'command => CORE::system($_[0])',
time => 'CORE::time',
umask => 'mask => CORE::umask($_[0])',
unlink => 'filename => CORE::unlink($_[0])',
utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])',
wait => 'CORE::wait()',
waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])',
);
sub import {
my $pkg = shift;
load_imports() unless $loaded++;
# Grandfather old foo_h form to new :foo_h form
s/^(?=\w+_h$)/:/ for my @list = @_;
my @unimpl = sort grep { exists $replacement{$_} } @list;
if (@unimpl) {
for my $u (@unimpl) {
warn "Unimplemented: POSIX::$u(): ", unimplemented_message($u);
}
croak(sprintf("Unimplemented: %s",
join(" ", map { "POSIX::$_()" } @unimpl)));
}
local $Exporter::ExportLevel = 1;
Exporter::import($pkg,@list);
}
eval join ';', map "sub $_", keys %replacement, keys %reimpl;
sub unimplemented_message {
my $func = shift;
my $how = $replacement{$func};
return "C-specific, stopped" unless defined $how;
return "$$how" if ref $how;
return "$how instead" if $how =~ /^use /;
return "Use method $how() instead" if $how =~ /::/;
return "C-specific: use $how instead";
}
sub AUTOLOAD {
my ($func) = ($AUTOLOAD =~ /.*::(.*)/);
die "POSIX.xs has failed to load\n" if $func eq 'constant';
if (my $code = $reimpl{$func}) {
my ($num, $arg) = (0, '');
if ($code =~ s/^(.*?) *=> *//) {
$arg = $1;
$num = 1 + $arg =~ tr/,//;
}
# no warnings to be consistent with the old implementation, where each
# function was in its own little AutoSplit world:
eval qq{ sub $func {
no warnings;
usage "$func($arg)" if \@_ != $num;
$code
} };
no strict;
goto &$AUTOLOAD;
}
if (exists $replacement{$func}) {
croak "Unimplemented: POSIX::$func(): ", unimplemented_message($func);
}
constant($func);
}
sub perror {
print STDERR "@_: " if @_;
print STDERR $!,"\n";
}
sub printf {
usage "printf(pattern, args...)" if @_ < 1;
CORE::printf STDOUT @_;
}
sub sprintf {
usage "sprintf(pattern, args...)" if @_ == 0;
CORE::sprintf(shift,@_);
}
sub load_imports {
my %default_export_tags = ( # cf. exports policy below
assert_h => [qw(assert NDEBUG)],
ctype_h => [],
dirent_h => [],
errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN
EALREADY EBADF EBADMSG EBUSY ECANCELED ECHILD ECONNABORTED
ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT EEXIST
EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS
EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE
ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS
ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEM ENOMSG
ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR
ENOTEMPTY ENOTRECOVERABLE ENOTSOCK ENOTSUP ENOTTY ENXIO
EOPNOTSUPP EOTHER EOVERFLOW EOWNERDEAD EPERM EPFNOSUPPORT EPIPE
EPROCLIM EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE
ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE
ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV
errno)],
fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK
O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK
O_RDONLY O_RDWR O_TRUNC O_WRONLY
creat
SEEK_CUR SEEK_END SEEK_SET
S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
S_IWGRP S_IWOTH S_IWUSR)],
float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
FLT_DIG FLT_EPSILON FLT_MANT_DIG
FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP
FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP
FLT_RADIX FLT_ROUNDS
LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG
LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP
LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)],
grp_h => [],
limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON
MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX
PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN
SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX
ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX
_POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
_POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX
_POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX
_POSIX_STREAM_MAX _POSIX_TZNAME_MAX)],
locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES
LC_MONETARY LC_NUMERIC LC_TIME NULL
localeconv setlocale)],
math_h => [qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL
FP_SUBNORMAL FP_ZERO
M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 M_LOG10E M_LOG2E
M_PI M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2
HUGE_VAL INFINITY NAN
acos asin atan ceil cosh fabs floor fmod
frexp ldexp log10 modf pow sinh tan tanh)],
pwd_h => [],
setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK
SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM
SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL
SIGPIPE %SIGRT SIGRTMIN SIGRTMAX SIGQUIT SIGSEGV SIGSTOP
SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIGBUS
SIGPOLL SIGPROF SIGSYS SIGTRAP SIGURG SIGVTALRM SIGXCPU SIGXFSZ
SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK
raise sigaction signal sigpending sigprocmask sigsuspend)],
stdarg_h => [],
stddef_h => [qw(NULL offsetof)],
stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
NULL SEEK_CUR SEEK_END SEEK_SET
STREAM_MAX TMP_MAX stderr stdin stdout
clearerr fclose fdopen feof ferror fflush fgetc fgetpos
fgets fopen fprintf fputc fputs fread freopen
fscanf fseek fsetpos ftell fwrite getchar gets
perror putc putchar puts remove rewind
scanf setbuf setvbuf sscanf tmpfile tmpnam
ungetc vfprintf vprintf vsprintf)],
stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
abort atexit atof atoi atol bsearch calloc div
free getenv labs ldiv malloc mblen mbstowcs mbtowc
qsort realloc strtod strtol strtoul wcstombs wctomb)],
string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
strchr strcmp strcoll strcpy strcspn strerror strlen
strncat strncmp strncpy strpbrk strrchr strspn strstr
strtok strxfrm)],
sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
fstat mkfifo)],
sys_times_h => [],
sys_types_h => [],
sys_utsname_h => [qw(uname)],
sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
WNOHANG WSTOPSIG WTERMSIG WUNTRACED)],
termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL
CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK
ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR
INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST
PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION
TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW
TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART
VSTOP VSUSP VTIME
cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain
tcflow tcflush tcgetattr tcsendbreak tcsetattr )],
time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
difftime mktime strftime tzset tzname)],
unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK
_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON
_PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX
_PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED
_POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS
_POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX
_SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL
_SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS
_SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
_exit access ctermid cuserid
dup2 dup execl execle execlp execv execve execvp
fpathconf fsync getcwd getegid geteuid getgid getgroups
getpid getuid isatty lseek pathconf pause setgid setpgid
setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
utime_h => [],
);
if ($^O eq 'MSWin32') {
$default_export_tags{winsock_h} = [qw(
WSAEINTR WSAEBADF WSAEACCES WSAEFAULT WSAEINVAL WSAEMFILE WSAEWOULDBLOCK
WSAEINPROGRESS WSAEALREADY WSAENOTSOCK WSAEDESTADDRREQ WSAEMSGSIZE
WSAEPROTOTYPE WSAENOPROTOOPT WSAEPROTONOSUPPORT WSAESOCKTNOSUPPORT
WSAEOPNOTSUPP WSAEPFNOSUPPORT WSAEAFNOSUPPORT WSAEADDRINUSE
WSAEADDRNOTAVAIL WSAENETDOWN WSAENETUNREACH WSAENETRESET WSAECONNABORTED
WSAECONNRESET WSAENOBUFS WSAEISCONN WSAENOTCONN WSAESHUTDOWN
WSAETOOMANYREFS WSAETIMEDOUT WSAECONNREFUSED WSAELOOP WSAENAMETOOLONG
WSAEHOSTDOWN WSAEHOSTUNREACH WSAENOTEMPTY WSAEPROCLIM WSAEUSERS
WSAEDQUOT WSAESTALE WSAEREMOTE WSAEDISCON WSAENOMORE WSAECANCELLED
WSAEINVALIDPROCTABLE WSAEINVALIDPROVIDER WSAEPROVIDERFAILEDINIT
WSAEREFUSED)];
}
my %other_export_tags = ( # cf. exports policy below
fenv_h => [qw(
FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD fegetround fesetround
)],
math_h_c99 => [ @{$default_export_tags{math_h}}, qw(
Inf NaN acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma
fmax fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal
isinf isless islessequal islessgreater isnan isnormal isunordered j0 j1
jn lgamma log1p log2 logb lrint lround nan nearbyint nextafter nexttoward
remainder remquo rint round scalbn signbit tgamma trunc y0 y1 yn
)],
netdb_h => [qw(EAI_AGAIN EAI_BADFLAGS EAI_FAIL
EAI_FAMILY EAI_MEMORY EAI_NONAME
EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE
EAI_SYSTEM)],
stdlib_h_c99 => [ @{$default_export_tags{stdlib_h}}, 'strtold' ],
sys_socket_h => [qw(
MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK MSG_TRUNC MSG_WAITALL
)],
nan_payload => [ qw(getpayload setpayload setpayloadsig issignaling) ],
signal_h_si_code => [qw(
ILL_ILLOPC ILL_ILLOPN ILL_ILLADR ILL_ILLTRP ILL_PRVOPC ILL_PRVREG
ILL_COPROC ILL_BADSTK
FPE_INTDIV FPE_INTOVF FPE_FLTDIV FPE_FLTOVF FPE_FLTUND
FPE_FLTRES FPE_FLTINV FPE_FLTSUB
SEGV_MAPERR SEGV_ACCERR
BUS_ADRALN BUS_ADRERR BUS_OBJERR
TRAP_BRKPT TRAP_TRACE
CLD_EXITED CLD_KILLED CLD_DUMPED CLD_TRAPPED CLD_STOPPED CLD_CONTINUED
POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP
SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ
)],
);
# exports policy:
# - new functions may not be added to @EXPORT, only to @EXPORT_OK
# - new SHOUTYCONSTANTS are OK to add to @EXPORT
{
# De-duplicate the export list:
my ( %export, %export_ok );
@export {map {@$_} values %default_export_tags} = ();
@export_ok{map {@$_} values %other_export_tags} = ();
# Doing the de-dup with a temporary hash has the advantage that the SVs in
# @EXPORT are actually shared hash key scalars, which will save some memory.
our @EXPORT = keys %export;
# you do not want to add symbols to the following list. add a new tag instead
our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write
printf sprintf),
grep {!exists $export{$_}} keys %reimpl, keys %replacement, keys %export_ok);
our %EXPORT_TAGS = ( %default_export_tags, %other_export_tags );
}
require Exporter;
}
package POSIX::SigAction;
sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} };
sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} };
sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} };
sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
{
package POSIX::SigSet;
# This package is here entirely to make sure that POSIX::SigSet is seen by the
# PAUSE indexer, so that it will always be clearly indexed in core. This is to
# prevent the accidental case where a third-party distribution can accidentally
# claim the POSIX::SigSet package, as occurred in 2011-12. -- rjbs, 2011-12-30
}
package POSIX::SigRt;
require Tie::Hash;
our @ISA = 'Tie::StdHash';
our ($_SIGRTMIN, $_SIGRTMAX, $_sigrtn);
our $SIGACTION_FLAGS = 0;
sub _init {
$_SIGRTMIN = &POSIX::SIGRTMIN;
$_SIGRTMAX = &POSIX::SIGRTMAX;
$_sigrtn = $_SIGRTMAX - $_SIGRTMIN;
}
sub _croak {
&_init unless defined $_sigrtn;
die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0;
}
sub _getsig {
&_croak;
my $rtsig = $_[0];
# Allow (SIGRT)?MIN( + n)?, a common idiom when doing these things in C.
$rtsig = $_SIGRTMIN + ($1 || 0)
if $rtsig =~ /^(?:(?:SIG)?RT)?MIN(\s*\+\s*(\d+))?$/;
return $rtsig;
}
sub _exist {
my $rtsig = _getsig($_[1]);
my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX;
($rtsig, $ok);
}
sub _check {
my ($rtsig, $ok) = &_exist;
die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)"
unless $ok;
return $rtsig;
}
sub new {
my ($rtsig, $handler, $flags) = @_;
my $sigset = POSIX::SigSet->new($rtsig);
my $sigact = POSIX::SigAction->new($handler, $sigset, $flags);
POSIX::sigaction($rtsig, $sigact);
}
sub EXISTS { &_exist }
sub FETCH { my $rtsig = &_check;
my $oa = POSIX::SigAction->new();
POSIX::sigaction($rtsig, undef, $oa);
return $oa->{HANDLER} }
sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) }
sub DELETE { delete $SIG{ &_check } }
sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } }
sub SCALAR { &_croak; $_sigrtn + 1 }
tie %POSIX::SIGRT, 'POSIX::SigRt';
# and the expression on the line above is true, so we return true.

62
vendor/LeOS/tools-leos/common/perl-base/Scalar/Util.pm vendored
View File

@ -1,62 +0,0 @@
# Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk>
package Scalar::Util;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
blessed refaddr reftype weaken unweaken isweak
dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
tainted
);
our $VERSION = "1.46_02";
$VERSION = eval $VERSION;
require List::Util; # List::Util loads the XS
List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863)
our @EXPORT_FAIL;
unless (defined &weaken) {
push @EXPORT_FAIL, qw(weaken);
}
unless (defined &isweak) {
push @EXPORT_FAIL, qw(isweak isvstring);
}
unless (defined &isvstring) {
push @EXPORT_FAIL, qw(isvstring);
}
sub export_fail {
if (grep { /^(?:weaken|isweak)$/ } @_ ) {
require Carp;
Carp::croak("Weak references are not implemented in the version of perl");
}
if (grep { /^isvstring$/ } @_ ) {
require Carp;
Carp::croak("Vstrings are not implemented in the version of perl");
}
@_;
}
# set_prototype has been moved to Sub::Util with a different interface
sub set_prototype(&$)
{
my ( $code, $proto ) = @_;
return Sub::Util::set_prototype( $proto, $code );
}
1;
__END__

22
vendor/LeOS/tools-leos/common/perl-base/SelectSaver.pm vendored
View File

@ -1,22 +0,0 @@
package SelectSaver;
our $VERSION = '1.02';
require 5.000;
use Carp;
use Symbol;
sub new {
@_ >= 1 && @_ <= 2 or croak 'usage: SelectSaver->new( [FILEHANDLE] )';
my $fh = select;
my $self = bless \$fh, $_[0];
select qualify($_[1], caller) if @_ > 1;
$self;
}
sub DESTROY {
my $self = $_[0];
select $$self;
}
1;

444
vendor/LeOS/tools-leos/common/perl-base/Socket.pm vendored
View File

@ -1,444 +0,0 @@
package Socket;
use strict;
{ use 5.006001; }
our $VERSION = '2.020_03'; # patched in perl5.git
# Still undocumented: SCM_*, SOMAXCONN, IOV_MAX, UIO_MAXIOV
use Carp;
use warnings::register;
require Exporter;
require XSLoader;
our @ISA = qw(Exporter);
# <@Nicholas> you can't change @EXPORT without breaking the implicit API
# Please put any new constants in @EXPORT_OK!
# List re-ordered to match documentation above. Try to keep the ordering
# consistent so it's easier to see which ones are or aren't documented.
our @EXPORT = qw(
PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT
PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6
PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI
PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN
PF_X25
AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT
AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6
AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI
AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN
AF_X25
SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM
SOL_SOCKET
SO_ACCEPTCONN SO_ATTACH_FILTER SO_BACKLOG SO_BROADCAST SO_CHAMELEON
SO_DEBUG SO_DETACH_FILTER SO_DGRAM_ERRIND SO_DOMAIN SO_DONTLINGER
SO_DONTROUTE SO_ERROR SO_FAMILY SO_KEEPALIVE SO_LINGER SO_OOBINLINE
SO_PASSCRED SO_PASSIFNAME SO_PEERCRED SO_PROTOCOL SO_PROTOTYPE
SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
SO_SECURITY_AUTHENTICATION SO_SECURITY_ENCRYPTION_NETWORK
SO_SECURITY_ENCRYPTION_TRANSPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO
SO_STATE SO_TYPE SO_USELOOPBACK SO_XOPEN SO_XSE
IP_OPTIONS IP_HDRINCL IP_TOS IP_TTL IP_RECVOPTS IP_RECVRETOPTS
IP_RETOPTS
MSG_BCAST MSG_BTAG MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC MSG_DONTROUTE
MSG_DONTWAIT MSG_EOF MSG_EOR MSG_ERRQUEUE MSG_ETAG MSG_FIN
MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK MSG_PROXY MSG_RST
MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL MSG_WIRE
SHUT_RD SHUT_RDWR SHUT_WR
INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP
SOMAXCONN
IOV_MAX
UIO_MAXIOV
sockaddr_family
pack_sockaddr_in unpack_sockaddr_in sockaddr_in
pack_sockaddr_in6 unpack_sockaddr_in6 sockaddr_in6
pack_sockaddr_un unpack_sockaddr_un sockaddr_un
inet_aton inet_ntoa
);
# List re-ordered to match documentation above. Try to keep the ordering
# consistent so it's easier to see which ones are or aren't documented.
our @EXPORT_OK = qw(
CR LF CRLF $CR $LF $CRLF
SOCK_NONBLOCK SOCK_CLOEXEC
IP_ADD_MEMBERSHIP IP_ADD_SOURCE_MEMBERSHIP IP_DROP_MEMBERSHIP
IP_DROP_SOURCE_MEMBERSHIP IP_MULTICAST_IF IP_MULTICAST_LOOP
IP_MULTICAST_TTL
IPPROTO_IP IPPROTO_IPV6 IPPROTO_RAW IPPROTO_ICMP IPPROTO_IGMP
IPPROTO_TCP IPPROTO_UDP IPPROTO_GRE IPPROTO_ESP IPPROTO_AH
IPPROTO_SCTP
IPTOS_LOWDELAY IPTOS_THROUGHPUT IPTOS_RELIABILITY IPTOS_MINCOST
TCP_CONGESTION TCP_CONNECTIONTIMEOUT TCP_CORK TCP_DEFER_ACCEPT TCP_INFO
TCP_INIT_CWND TCP_KEEPALIVE TCP_KEEPCNT TCP_KEEPIDLE TCP_KEEPINTVL
TCP_LINGER2 TCP_MAXRT TCP_MAXSEG TCP_MD5SIG TCP_NODELAY TCP_NOOPT
TCP_NOPUSH TCP_QUICKACK TCP_SACK_ENABLE TCP_STDURG TCP_SYNCNT
TCP_WINDOW_CLAMP
IN6ADDR_ANY IN6ADDR_LOOPBACK
IPV6_ADD_MEMBERSHIP IPV6_DROP_MEMBERSHIP IPV6_JOIN_GROUP
IPV6_LEAVE_GROUP IPV6_MTU IPV6_MTU_DISCOVER IPV6_MULTICAST_HOPS
IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_UNICAST_HOPS IPV6_V6ONLY
pack_ip_mreq unpack_ip_mreq pack_ip_mreq_source unpack_ip_mreq_source
pack_ipv6_mreq unpack_ipv6_mreq
inet_pton inet_ntop
getaddrinfo getnameinfo
AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN
AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST
AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED
NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES
NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV
NIx_NOHOST NIx_NOSERV
EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY
EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM
);
our %EXPORT_TAGS = (
crlf => [qw(CR LF CRLF $CR $LF $CRLF)],
addrinfo => [qw(getaddrinfo getnameinfo), grep m/^(?:AI|NI|NIx|EAI)_/, @EXPORT_OK],
all => [@EXPORT, @EXPORT_OK],
);
BEGIN {
sub CR () {"\015"}
sub LF () {"\012"}
sub CRLF () {"\015\012"}
# These are not gni() constants; they're extensions for the perl API
# The definitions in Socket.pm and Socket.xs must match
sub NIx_NOHOST() {1 << 0}
sub NIx_NOSERV() {1 << 1}
}
*CR = \CR();
*LF = \LF();
*CRLF = \CRLF();
sub sockaddr_in {
if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die
my($af, $port, @quad) = @_;
warnings::warn "6-ARG sockaddr_in call is deprecated"
if warnings::enabled();
pack_sockaddr_in($port, inet_aton(join('.', @quad)));
} elsif (wantarray) {
croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1;
unpack_sockaddr_in(@_);
} else {
croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2;
pack_sockaddr_in(@_);
}
}
sub sockaddr_in6 {
if (wantarray) {
croak "usage: (port,in6addr,scope_id,flowinfo) = sockaddr_in6(sin6_sv)" unless @_ == 1;
unpack_sockaddr_in6(@_);
}
else {
croak "usage: sin6_sv = sockaddr_in6(port,in6addr,[scope_id,[flowinfo]])" unless @_ >= 2 and @_ <= 4;
pack_sockaddr_in6(@_);
}
}
sub sockaddr_un {
if (wantarray) {
croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1;
unpack_sockaddr_un(@_);
} else {
croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1;
pack_sockaddr_un(@_);
}
}
XSLoader::load(__PACKAGE__, $VERSION);
my %errstr;
if( defined &getaddrinfo ) {
# These are not part of the API, nothing uses them, and deleting them
# reduces the size of %Socket:: by about 12K
delete $Socket::{fake_getaddrinfo};
delete $Socket::{fake_getnameinfo};
} else {
require Scalar::Util;
*getaddrinfo = \&fake_getaddrinfo;
*getnameinfo = \&fake_getnameinfo;
# These numbers borrowed from GNU libc's implementation, but since
# they're only used by our emulation, it doesn't matter if the real
# platform's values differ
my %constants = (
AI_PASSIVE => 1,
AI_CANONNAME => 2,
AI_NUMERICHOST => 4,
AI_V4MAPPED => 8,
AI_ALL => 16,
AI_ADDRCONFIG => 32,
# RFC 2553 doesn't define this but Linux does - lets be nice and
# provide it since we can
AI_NUMERICSERV => 1024,
EAI_BADFLAGS => -1,
EAI_NONAME => -2,
EAI_NODATA => -5,
EAI_FAMILY => -6,
EAI_SERVICE => -8,
NI_NUMERICHOST => 1,
NI_NUMERICSERV => 2,
NI_NOFQDN => 4,
NI_NAMEREQD => 8,
NI_DGRAM => 16,
# Constants we don't support. Export them, but croak if anyone tries to
# use them
AI_IDN => 64,
AI_CANONIDN => 128,
AI_IDN_ALLOW_UNASSIGNED => 256,
AI_IDN_USE_STD3_ASCII_RULES => 512,
NI_IDN => 32,
NI_IDN_ALLOW_UNASSIGNED => 64,
NI_IDN_USE_STD3_ASCII_RULES => 128,
# Error constants we'll never return, so it doesn't matter what value
# these have, nor that we don't provide strings for them
EAI_SYSTEM => -11,
EAI_BADHINTS => -1000,
EAI_PROTOCOL => -1001
);
foreach my $name ( keys %constants ) {
my $value = $constants{$name};
no strict 'refs';
defined &$name or *$name = sub () { $value };
}
%errstr = (
# These strings from RFC 2553
EAI_BADFLAGS() => "invalid value for ai_flags",
EAI_NONAME() => "nodename nor servname provided, or not known",
EAI_NODATA() => "no address associated with nodename",
EAI_FAMILY() => "ai_family not supported",
EAI_SERVICE() => "servname not supported for ai_socktype",
);
}
# The following functions are used if the system does not have a
# getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET
# family
# Borrowed from Regexp::Common::net
my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}/;
my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/;
sub fake_makeerr
{
my ( $errno ) = @_;
my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno );
return Scalar::Util::dualvar( $errno, $errstr );
}
sub fake_getaddrinfo
{
my ( $node, $service, $hints ) = @_;
$node = "" unless defined $node;
$service = "" unless defined $service;
my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )};
$family ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too
$family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() );
$socktype ||= 0;
$protocol ||= 0;
$flags ||= 0;
my $flag_passive = $flags & AI_PASSIVE(); $flags &= ~AI_PASSIVE();
my $flag_canonname = $flags & AI_CANONNAME(); $flags &= ~AI_CANONNAME();
my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST();
my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV();
# These constants don't apply to AF_INET-only lookups, so we might as well
# just ignore them. For AI_ADDRCONFIG we just presume the host has ability
# to talk AF_INET. If not we'd have to return no addresses at all. :)
$flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG());
$flags & (AI_IDN()|AI_CANONIDN()|AI_IDN_ALLOW_UNASSIGNED()|AI_IDN_USE_STD3_ASCII_RULES()) and
croak "Socket::getaddrinfo() does not support IDN";
$flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
$node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() );
my $canonname;
my @addrs;
if( $node ne "" ) {
return fake_makeerr( EAI_NONAME() ) if( $flag_numerichost and $node !~ m/^$REGEXP_IPv4_DOTTEDQUAD$/ );
( $canonname, undef, undef, undef, @addrs ) = gethostbyname( $node );
defined $canonname or return fake_makeerr( EAI_NONAME() );
undef $canonname unless $flag_canonname;
}
else {
$addrs[0] = $flag_passive ? Socket::inet_aton( "0.0.0.0" )
: Socket::inet_aton( "127.0.0.1" );
}
my @ports; # Actually ARRAYrefs of [ socktype, protocol, port ]
my $protname = "";
if( $protocol ) {
$protname = eval { getprotobynumber( $protocol ) };
}
if( $service ne "" and $service !~ m/^\d+$/ ) {
return fake_makeerr( EAI_NONAME() ) if( $flag_numericserv );
getservbyname( $service, $protname ) or return fake_makeerr( EAI_SERVICE() );
}
foreach my $this_socktype ( Socket::SOCK_STREAM(), Socket::SOCK_DGRAM(), Socket::SOCK_RAW() ) {
next if $socktype and $this_socktype != $socktype;
my $this_protname = "raw";
$this_socktype == Socket::SOCK_STREAM() and $this_protname = "tcp";
$this_socktype == Socket::SOCK_DGRAM() and $this_protname = "udp";
next if $protname and $this_protname ne $protname;
my $port;
if( $service ne "" ) {
if( $service =~ m/^\d+$/ ) {
$port = "$service";
}
else {
( undef, undef, $port, $this_protname ) = getservbyname( $service, $this_protname );
next unless defined $port;
}
}
else {
$port = 0;
}
push @ports, [ $this_socktype, eval { scalar getprotobyname( $this_protname ) } || 0, $port ];
}
my @ret;
foreach my $addr ( @addrs ) {
foreach my $portspec ( @ports ) {
my ( $socktype, $protocol, $port ) = @$portspec;
push @ret, {
family => $family,
socktype => $socktype,
protocol => $protocol,
addr => Socket::pack_sockaddr_in( $port, $addr ),
canonname => undef,
};
}
}
# Only supply canonname for the first result
if( defined $canonname ) {
$ret[0]->{canonname} = $canonname;
}
return ( fake_makeerr( 0 ), @ret );
}
sub fake_getnameinfo
{
my ( $addr, $flags, $xflags ) = @_;
my ( $port, $inetaddr );
eval { ( $port, $inetaddr ) = Socket::unpack_sockaddr_in( $addr ) }
or return fake_makeerr( EAI_FAMILY() );
my $family = Socket::AF_INET();
$flags ||= 0;
my $flag_numerichost = $flags & NI_NUMERICHOST(); $flags &= ~NI_NUMERICHOST();
my $flag_numericserv = $flags & NI_NUMERICSERV(); $flags &= ~NI_NUMERICSERV();
my $flag_nofqdn = $flags & NI_NOFQDN(); $flags &= ~NI_NOFQDN();
my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD();
my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM();
$flags & (NI_IDN()|NI_IDN_ALLOW_UNASSIGNED()|NI_IDN_USE_STD3_ASCII_RULES()) and
croak "Socket::getnameinfo() does not support IDN";
$flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
$xflags ||= 0;
my $node;
if( $xflags & NIx_NOHOST ) {
$node = undef;
}
elsif( $flag_numerichost ) {
$node = Socket::inet_ntoa( $inetaddr );
}
else {
$node = gethostbyaddr( $inetaddr, $family );
if( !defined $node ) {
return fake_makeerr( EAI_NONAME() ) if $flag_namereqd;
$node = Socket::inet_ntoa( $inetaddr );
}
elsif( $flag_nofqdn ) {
my ( $shortname ) = split m/\./, $node;
my ( $fqdn ) = gethostbyname $shortname;
$node = $shortname if defined $fqdn and $fqdn eq $node;
}
}
my $service;
if( $xflags & NIx_NOSERV ) {
$service = undef;
}
elsif( $flag_numericserv ) {
$service = "$port";
}
else {
my $protname = $flag_dgram ? "udp" : "";
$service = getservbyport( $port, $protname );
if( !defined $service ) {
$service = "$port";
}
}
return ( fake_makeerr( 0 ), $node, $service );
}
1;

91
vendor/LeOS/tools-leos/common/perl-base/Symbol.pm vendored
View File

@ -1,91 +0,0 @@
package Symbol;
BEGIN { require 5.005; }
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
@EXPORT_OK = qw(delete_package geniosym);
$VERSION = '1.08';
my $genpkg = "Symbol::";
my $genseq = 0;
my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
#
# Note that we never _copy_ the glob; we just make a ref to it.
# If we did copy it, then SVf_FAKE would be set on the copy, and
# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
#
sub gensym () {
my $name = "GEN" . $genseq++;
my $ref = \*{$genpkg . $name};
delete $$genpkg{$name};
$ref;
}
sub geniosym () {
my $sym = gensym();
# force the IO slot to be filled
select(select $sym);
*$sym{IO};
}
sub ungensym ($) {}
sub qualify ($;$) {
my ($name) = @_;
if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
my $pkg;
# Global names: special character, "^xyz", or other.
if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
# RGS 2001-11-05 : translate leading ^X to control-char
$name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
$pkg = "main";
}
else {
$pkg = (@_ > 1) ? $_[1] : caller;
}
$name = $pkg . "::" . $name;
}
$name;
}
sub qualify_to_ref ($;$) {
return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
}
#
# of Safe.pm lineage
#
sub delete_package ($) {
my $pkg = shift;
# expand to full symbol table name if needed
unless ($pkg =~ /^main::.*::$/) {
$pkg = "main$pkg" if $pkg =~ /^::/;
$pkg = "main::$pkg" unless $pkg =~ /^main::/;
$pkg .= '::' unless $pkg =~ /::$/;
}
my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
my $stem_symtab = *{$stem}{HASH};
return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
# free all the symbols in the package
my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
foreach my $name (keys %$leaf_symtab) {
undef *{$pkg . $name};
}
# delete the symbol table
%$leaf_symtab = ();
delete $stem_symtab->{$leaf};
}
1;

166
vendor/LeOS/tools-leos/common/perl-base/Text/ParseWords.pm vendored
View File

@ -1,166 +0,0 @@
package Text::ParseWords;
use strict;
require 5.006;
our $VERSION = "3.30";
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(shellwords quotewords nested_quotewords parse_line);
our @EXPORT_OK = qw(old_shellwords);
our $PERL_SINGLE_QUOTE;
sub shellwords {
my (@lines) = @_;
my @allwords;
foreach my $line (@lines) {
$line =~ s/^\s+//;
my @words = parse_line('\s+', 0, $line);
pop @words if (@words and !defined $words[-1]);
return() unless (@words || !length($line));
push(@allwords, @words);
}
return(@allwords);
}
sub quotewords {
my($delim, $keep, @lines) = @_;
my($line, @words, @allwords);
foreach $line (@lines) {
@words = parse_line($delim, $keep, $line);
return() unless (@words || !length($line));
push(@allwords, @words);
}
return(@allwords);
}
sub nested_quotewords {
my($delim, $keep, @lines) = @_;
my($i, @allwords);
for ($i = 0; $i < @lines; $i++) {
@{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]);
return() unless (@{$allwords[$i]} || !length($lines[$i]));
}
return(@allwords);
}
sub parse_line {
my($delimiter, $keep, $line) = @_;
my($word, @pieces);
no warnings 'uninitialized'; # we will be testing undef strings
while (length($line)) {
# This pattern is optimised to be stack conservative on older perls.
# Do not refactor without being careful and testing it on very long strings.
# See Perl bug #42980 for an example of a stack busting input.
$line =~ s/^
(?:
# double quoted string
(") # $quote
((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted
| # --OR--
# singe quoted string
(') # $quote
((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted
| # --OR--
# unquoted string
( # $unquoted
(?:\\.|[^\\"'])*?
)
# followed by
( # $delim
\Z(?!\n) # EOL
| # --OR--
(?-x:$delimiter) # delimiter
| # --OR--
(?!^)(?=["']) # a quote
)
)//xs or return; # extended layout
my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6);
return() unless( defined($quote) || length($unquoted) || length($delim));
if ($keep) {
$quoted = "$quote$quoted$quote";
}
else {
$unquoted =~ s/\\(.)/$1/sg;
if (defined $quote) {
$quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
}
}
$word .= substr($line, 0, 0); # leave results tainted
$word .= defined $quote ? $quoted : $unquoted;
if (length($delim)) {
push(@pieces, $word);
push(@pieces, $delim) if ($keep eq 'delimiters');
undef $word;
}
if (!length($line)) {
push(@pieces, $word);
}
}
return(@pieces);
}
sub old_shellwords {
# Usage:
# use ParseWords;
# @words = old_shellwords($line);
# or
# @words = old_shellwords(@lines);
# or
# @words = old_shellwords(); # defaults to $_ (and clobbers it)
no warnings 'uninitialized'; # we will be testing undef strings
local *_ = \join('', @_) if @_;
my (@words, $snippet);
s/\A\s+//;
while ($_ ne '') {
my $field = substr($_, 0, 0); # leave results tainted
for (;;) {
if (s/\A"(([^"\\]|\\.)*)"//s) {
($snippet = $1) =~ s#\\(.)#$1#sg;
}
elsif (/\A"/) {
require Carp;
Carp::carp("Unmatched double quote: $_");
return();
}
elsif (s/\A'(([^'\\]|\\.)*)'//s) {
($snippet = $1) =~ s#\\(.)#$1#sg;
}
elsif (/\A'/) {
require Carp;
Carp::carp("Unmatched single quote: $_");
return();
}
elsif (s/\A\\(.?)//s) {
$snippet = $1;
}
elsif (s/\A([^\s\\'"]+)//) {
$snippet = $1;
}
else {
s/\A\s+//;
last;
}
$field .= $snippet;
}
push(@words, $field);
}
return @words;
}
1;
__END__

100
vendor/LeOS/tools-leos/common/perl-base/Text/Tabs.pm vendored
View File

@ -1,100 +0,0 @@
package Text::Tabs;
require Exporter;
@ISA = (Exporter);
@EXPORT = qw(expand unexpand $tabstop);
use vars qw($VERSION $SUBVERSION $tabstop $debug);
$VERSION = 2013.0523;
$SUBVERSION = 'modern';
use strict;
use 5.010_000;
BEGIN {
$tabstop = 8;
$debug = 0;
}
my $CHUNK = qr/\X/;
sub _xlen (_) { scalar(() = $_[0] =~ /$CHUNK/g) }
sub _xpos (_) { _xlen( substr( $_[0], 0, pos($_[0]) ) ) }
sub expand {
my @l;
my $pad;
for ( @_ ) {
my $s = '';
for (split(/^/m, $_, -1)) {
my $offs = 0;
s{\t}{
# this works on both 5.10 and 5.11
$pad = $tabstop - (_xlen(${^PREMATCH}) + $offs) % $tabstop;
# this works on 5.11, but fails on 5.10
#XXX# $pad = $tabstop - (_xpos() + $offs) % $tabstop;
$offs += $pad - 1;
" " x $pad;
}peg;
$s .= $_;
}
push(@l, $s);
}
return @l if wantarray;
return $l[0];
}
sub unexpand
{
my (@l) = @_;
my @e;
my $x;
my $line;
my @lines;
my $lastbit;
my $ts_as_space = " " x $tabstop;
for $x (@l) {
@lines = split("\n", $x, -1);
for $line (@lines) {
$line = expand($line);
@e = split(/(${CHUNK}{$tabstop})/,$line,-1);
$lastbit = pop(@e);
$lastbit = ''
unless defined $lastbit;
$lastbit = "\t"
if $lastbit eq $ts_as_space;
for $_ (@e) {
if ($debug) {
my $x = $_;
$x =~ s/\t/^I\t/gs;
print "sub on '$x'\n";
}
s/ +$/\t/;
}
$line = join('',@e, $lastbit);
}
$x = join("\n", @lines);
}
return @l if wantarray;
return $l[0];
}
1;
__END__
sub expand
{
my (@l) = @_;
for $_ (@l) {
1 while s/(^|\n)([^\t\n]*)(\t+)/
$1. $2 . (" " x
($tabstop * length($3)
- (length($2) % $tabstop)))
/sex;
}
return @l if wantarray;
return $l[0];
}

132
vendor/LeOS/tools-leos/common/perl-base/Text/Wrap.pm vendored
View File

@ -1,132 +0,0 @@
package Text::Wrap;
use warnings::register;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(wrap fill);
@EXPORT_OK = qw($columns $break $huge);
$VERSION = 2013.0523;
$SUBVERSION = 'modern';
use 5.010_000;
use vars qw($VERSION $SUBVERSION $columns $debug $break $huge $unexpand $tabstop $separator $separator2);
use strict;
BEGIN {
$columns = 76; # <= screen width
$debug = 0;
$break = '(?=\s)\X';
$huge = 'wrap'; # alternatively: 'die' or 'overflow'
$unexpand = 1;
$tabstop = 8;
$separator = "\n";
$separator2 = undef;
}
my $CHUNK = qr/\X/;
sub _xlen(_) { scalar(() = $_[0] =~ /$CHUNK/g) }
sub _xpos(_) { _xlen( substr( $_[0], 0, pos($_[0]) ) ) }
use Text::Tabs qw(expand unexpand);
sub wrap
{
my ($ip, $xp, @t) = @_;
local($Text::Tabs::tabstop) = $tabstop;
my $r = "";
my $tail = pop(@t);
my $t = expand(join("", (map { /\s+\z/ ? ( $_ ) : ($_, ' ') } @t), $tail));
my $lead = $ip;
my $nll = $columns - _xlen(expand($xp)) - 1;
if ($nll <= 0 && $xp ne '') {
my $nc = _xlen(expand($xp)) + 2;
warnings::warnif "Increasing \$Text::Wrap::columns from $columns to $nc to accommodate length of subsequent tab";
$columns = $nc;
$nll = 1;
}
my $ll = $columns - _xlen(expand($ip)) - 1;
$ll = 0 if $ll < 0;
my $nl = "";
my $remainder = "";
use re 'taint';
pos($t) = 0;
while ($t !~ /\G(?:$break)*\Z/gc) {
if ($t =~ /\G((?:(?=[^\n])\X){0,$ll})($break|\n+|\z)/xmgc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = $2;
} elsif ($huge eq 'wrap' && $t =~ /\G((?:(?=[^\n])\X){$ll})/gc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = defined($separator2) ? $separator2 : $separator;
} elsif ($huge eq 'overflow' && $t =~ /\G((?:(?=[^\n])\X)*?)($break|\n+|\z)/xmgc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = $2;
} elsif ($huge eq 'die') {
die "couldn't wrap '$t'";
} elsif ($columns < 2) {
warnings::warnif "Increasing \$Text::Wrap::columns from $columns to 2";
$columns = 2;
return ($ip, $xp, @t);
} else {
die "This shouldn't happen";
}
$lead = $xp;
$ll = $nll;
$nl = defined($separator2)
? ($remainder eq "\n"
? "\n"
: $separator2)
: $separator;
}
$r .= $remainder;
print "-----------$r---------\n" if $debug;
print "Finish up with '$lead'\n" if $debug;
my($opos) = pos($t);
$r .= $lead . substr($t, pos($t), length($t) - pos($t))
if pos($t) ne length($t);
print "-----------$r---------\n" if $debug;;
return $r;
}
sub fill
{
my ($ip, $xp, @raw) = @_;
my @para;
my $pp;
for $pp (split(/\n\s+/, join("\n",@raw))) {
$pp =~ s/\s+/ /g;
my $x = wrap($ip, $xp, $pp);
push(@para, $x);
}
# if paragraph_indent is the same as line_indent,
# separate paragraphs with blank lines
my $ps = ($ip eq $xp) ? "\n\n" : "\n";
return join ($ps, @para);
}
1;
__END__

85
vendor/LeOS/tools-leos/common/perl-base/Tie/Hash.pm vendored
View File

@ -1,85 +0,0 @@
package Tie::Hash;
our $VERSION = '1.05';
use Carp;
use warnings::register;
sub new {
my $pkg = shift;
$pkg->TIEHASH(@_);
}
# Grandfather "new"
sub TIEHASH {
my $pkg = shift;
my $pkg_new = $pkg -> can ('new');
if ($pkg_new and $pkg ne __PACKAGE__) {
my $my_new = __PACKAGE__ -> can ('new');
if ($pkg_new == $my_new) {
#
# Prevent recursion
#
croak "$pkg must define either a TIEHASH() or a new() method";
}
warnings::warnif ("WARNING: calling ${pkg}->new since " .
"${pkg}->TIEHASH is missing");
$pkg -> new (@_);
}
else {
croak "$pkg doesn't define a TIEHASH method";
}
}
sub EXISTS {
my $pkg = ref $_[0];
croak "$pkg doesn't define an EXISTS method";
}
sub CLEAR {
my $self = shift;
my $key = $self->FIRSTKEY(@_);
my @keys;
while (defined $key) {
push @keys, $key;
$key = $self->NEXTKEY(@_, $key);
}
foreach $key (@keys) {
$self->DELETE(@_, $key);
}
}
# The Tie::StdHash package implements standard perl hash behaviour.
# It exists to act as a base class for classes which only wish to
# alter some parts of their behaviour.
package Tie::StdHash;
# @ISA = qw(Tie::Hash); # would inherit new() only
sub TIEHASH { bless {}, $_[0] }
sub STORE { $_[0]->{$_[1]} = $_[2] }
sub FETCH { $_[0]->{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY { each %{$_[0]} }
sub EXISTS { exists $_[0]->{$_[1]} }
sub DELETE { delete $_[0]->{$_[1]} }
sub CLEAR { %{$_[0]} = () }
sub SCALAR { scalar %{$_[0]} }
package Tie::ExtraHash;
sub TIEHASH { my $p = shift; bless [{}, @_], $p }
sub STORE { $_[0][0]{$_[1]} = $_[2] }
sub FETCH { $_[0][0]{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
sub NEXTKEY { each %{$_[0][0]} }
sub EXISTS { exists $_[0][0]->{$_[1]} }
sub DELETE { delete $_[0][0]->{$_[1]} }
sub CLEAR { %{$_[0][0]} = () }
sub SCALAR { scalar %{$_[0][0]} }
1;

125
vendor/LeOS/tools-leos/common/perl-base/XSLoader.pm vendored
View File

@ -1,125 +0,0 @@
# Generated from XSLoader_pm.PL (resolved %Config::Config value)
# This file is unique for every OS
package XSLoader;
$VERSION = "0.27";
#use strict;
package DynaLoader;
# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
!defined(&dl_error);
package XSLoader;
sub load {
package DynaLoader;
my ($caller, $modlibname) = caller();
my $module = $caller;
if (@_) {
$module = $_[0];
} else {
$_[0] = $module;
}
# work with static linking too
my $boots = "$module\::bootstrap";
goto &$boots if defined &$boots;
goto \&XSLoader::bootstrap_inherit unless $module and defined &dl_load_file;
my @modparts = split(/::/,$module);
my $modfname = $modparts[-1];
my $modpname = join('/',@modparts);
my $c = () = split(/::/,$caller,-1);
$modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
# Does this look like a relative path?
if ($modlibname !~ m{^/}) {
# Someone may have a #line directive that changes the file name, or
# may be calling XSLoader::load from inside a string eval. We cer-
# tainly do not want to go loading some code that is not in @INC,
# as it could be untrusted.
#
# We could just fall back to DynaLoader here, but then the rest of
# this function would go untested in the perl core, since all @INC
# paths are relative during testing. That would be a time bomb
# waiting to happen, since bugs could be introduced into the code.
#
# So look through @INC to see if $modlibname is in it. A rela-
# tive $modlibname is not a common occurrence, so this block is
# not hot code.
FOUND: {
for (@INC) {
if ($_ eq $modlibname) {
last FOUND;
}
}
# Not found. Fall back to DynaLoader.
goto \&XSLoader::bootstrap_inherit;
}
}
my $file = "$modlibname/auto/$modpname/$modfname.so";
# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
my $bs = $file;
$bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
if (-s $bs) { # only read file if it's not empty
# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
eval { local @INC = ('.'); do $bs; };
warn "$bs: $@\n" if $@;
goto \&XSLoader::bootstrap_inherit;
}
goto \&XSLoader::bootstrap_inherit if not -f $file;
my $bootname = "boot_$module";
$bootname =~ s/\W/_/g;
@DynaLoader::dl_require_symbols = ($bootname);
my $boot_symbol_ref;
# Many dynamic extension loading problems will appear to come from
# this section of code: XYZ failed at line 123 of DynaLoader.pm.
# Often these errors are actually occurring in the initialisation
# C code of the extension XS file. Perl reports the error as being
# in this perl code simply because this was the last perl code
# it executed.
my $libref = dl_load_file($file, 0) or do {
require Carp;
Carp::croak("Can't load '$file' for module $module: " . dl_error());
};
push(@DynaLoader::dl_librefs,$libref); # record loaded object
$boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
require Carp;
Carp::croak("Can't find '$bootname' symbol in $file\n");
};
push(@DynaLoader::dl_modules, $module); # record loaded module
boot:
my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file);
# See comment block above
push(@DynaLoader::dl_shared_objects, $file); # record files loaded
return &$xs(@_);
}
sub bootstrap_inherit {
require DynaLoader;
goto \&DynaLoader::bootstrap_inherit;
}
1;
__END__

120
vendor/LeOS/tools-leos/common/perl-base/attributes.pm vendored
View File

@ -1,120 +0,0 @@
package attributes;
our $VERSION = 0.29;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
use strict;
sub croak {
require Carp;
goto &Carp::croak;
}
sub carp {
require Carp;
goto &Carp::carp;
}
my %deprecated;
$deprecated{CODE} = qr/\A-?(locked)\z/;
$deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR}
= qr/\A-?(unique)\z/;
my %msg = (
lvalue => 'lvalue attribute applied to already-defined subroutine',
-lvalue => 'lvalue attribute removed from already-defined subroutine',
const => 'Useless use of attribute "const"',
);
sub _modify_attrs_and_deprecate {
my $svtype = shift;
# Now that we've removed handling of locked from the XS code, we need to
# remove it here, else it ends up in @badattrs. (If we do the deprecation in
# XS, we can't control the warning based on *our* caller's lexical settings,
# and the warned line is in this package)
grep {
$deprecated{$svtype} && /$deprecated{$svtype}/ ? do {
require warnings;
warnings::warnif('deprecated', "Attribute \"$1\" is deprecated, " .
"and will disappear in Perl 5.28");
0;
} : $svtype eq 'CODE' && exists $msg{$_} ? do {
require warnings;
warnings::warnif(
'misc',
$msg{$_}
);
0;
} : 1
} _modify_attrs(@_);
}
sub import {
@_ > 2 && ref $_[2] or do {
require Exporter;
goto &Exporter::import;
};
my (undef,$home_stash,$svref,@attrs) = @_;
my $svtype = uc reftype($svref);
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
if defined $home_stash && $home_stash ne '';
my @badattrs;
if ($pkgmeth) {
my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
@badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
if (!@badattrs && @pkgattrs) {
require warnings;
return unless warnings::enabled('reserved');
@pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
if (@pkgattrs) {
for my $attr (@pkgattrs) {
$attr =~ s/\(.+\z//s;
}
my $s = ((@pkgattrs == 1) ? '' : 's');
carp "$svtype package attribute$s " .
"may clash with future reserved word$s: " .
join(' : ' , @pkgattrs);
}
}
}
else {
@badattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
}
if (@badattrs) {
croak "Invalid $svtype attribute" .
(( @badattrs == 1 ) ? '' : 's') .
": " .
join(' : ', @badattrs);
}
}
sub get ($) {
@_ == 1 && ref $_[0] or
croak 'Usage: '.__PACKAGE__.'::get $ref';
my $svref = shift;
my $svtype = uc reftype($svref);
my $stash = _guess_stash($svref);
$stash = caller unless defined $stash;
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
if defined $stash && $stash ne '';
return $pkgmeth ?
(_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
(_fetch_attrs($svref))
;
}
sub require_version { goto &UNIVERSAL::VERSION }
require XSLoader;
XSLoader::load();
1;
__END__
#The POD goes here

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/Cwd/Cwd.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/Fcntl/Fcntl.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/File/Glob/Glob.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/Hash/Util/Util.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/IO/IO.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/List/Util/Util.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/POSIX/POSIX.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/Socket/Socket.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/attributes/attributes.so vendored
View File

Binary file not shown.

BIN
vendor/LeOS/tools-leos/common/perl-base/auto/re/re.so vendored
View File

Binary file not shown.

243
vendor/LeOS/tools-leos/common/perl-base/base.pm vendored
View File

@ -1,243 +0,0 @@
use 5.008;
package base;
use strict 'vars';
use vars qw($VERSION);
$VERSION = '2.26';
$VERSION =~ tr/_//d;
# simplest way to avoid indexing of the package: no package statement
sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC }
# instance is blessed array of coderefs to be removed from @INC at scope exit
sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} }
# constant.pm is slow
sub SUCCESS () { 1 }
sub PUBLIC () { 2**0 }
sub PRIVATE () { 2**1 }
sub INHERITED () { 2**2 }
sub PROTECTED () { 2**3 }
my $Fattr = \%fields::attr;
sub has_fields {
my($base) = shift;
my $fglob = ${"$base\::"}{FIELDS};
return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
}
sub has_attr {
my($proto) = shift;
my($class) = ref $proto || $proto;
return exists $Fattr->{$class};
}
sub get_attr {
$Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
return $Fattr->{$_[0]};
}
if ($] < 5.009) {
*get_fields = sub {
# Shut up a possible typo warning.
() = \%{$_[0].'::FIELDS'};
my $f = \%{$_[0].'::FIELDS'};
# should be centralized in fields? perhaps
# fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
# is used here anyway, it doesn't matter.
bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
return $f;
}
}
else {
*get_fields = sub {
# Shut up a possible typo warning.
() = \%{$_[0].'::FIELDS'};
return \%{$_[0].'::FIELDS'};
}
}
if ($] < 5.008) {
*_module_to_filename = sub {
(my $fn = $_[0]) =~ s!::!/!g;
$fn .= '.pm';
return $fn;
}
}
else {
*_module_to_filename = sub {
(my $fn = $_[0]) =~ s!::!/!g;
$fn .= '.pm';
utf8::encode($fn);
return $fn;
}
}
sub import {
my $class = shift;
return SUCCESS unless @_;
# List of base classes from which we will inherit %FIELDS.
my $fields_base;
my $inheritor = caller(0);
my @bases;
foreach my $base (@_) {
if ( $inheritor eq $base ) {
warn "Class '$inheritor' tried to inherit from itself\n";
}
next if grep $_->isa($base), ($inheritor, @bases);
# Following blocks help isolate $SIG{__DIE__} and @INC changes
{
my $sigdie;
{
local $SIG{__DIE__};
my $fn = _module_to_filename($base);
my $dot_hidden;
eval {
my $guard;
if ($INC[-1] eq '.' && %{"$base\::"}) {
# So: the package already exists => this an optional load
# And: there is a dot at the end of @INC => we want to hide it
# However: we only want to hide it during our *own* require()
# (i.e. without affecting nested require()s).
# So we add a hook to @INC whose job is to hide the dot, but which
# first checks checks the callstack depth, because within nested
# require()s the callstack is deeper.
# Since CORE::GLOBAL::require makes it unknowable in advance what
# the exact relevant callstack depth will be, we have to record it
# inside a hook. So we put another hook just for that at the front
# of @INC, where it's guaranteed to run -- immediately.
# The dot-hiding hook does its job by sitting directly in front of
# the dot and removing itself from @INC when reached. This causes
# the dot to move up one index in @INC, causing the loop inside
# pp_require() to skip it.
# Loaded coded may disturb this precise arrangement, but that's OK
# because the hook is inert by that time. It is only active during
# the top-level require(), when @INC is in our control. The only
# possible gotcha is if other hooks already in @INC modify @INC in
# some way during that initial require().
# Note that this jiggery hookery works just fine recursively: if
# a module loaded via base.pm uses base.pm itself, there will be
# one pair of hooks in @INC per base::import call frame, but the
# pairs from different nestings do not interfere with each other.
my $lvl;
unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () };
splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () };
$guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard';
}
require $fn
};
if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) {
require Carp;
Carp::croak(<<ERROR);
Base class package "$base" is not empty but "$fn[0]" exists in the current directory.
To help avoid security issues, base.pm now refuses to load optional modules
from the current working directory when it is the last entry in \@INC.
If your software worked on previous versions of Perl, the best solution
is to use FindBin to detect the path properly and to add that path to
\@INC. As a last resort, you can re-enable looking in the current working
directory by adding "use lib '.'" to your code.
ERROR
}
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
#
# changing the check here is fragile - if the check
# here isn't catching every error you want, you should
# probably be using parent.pm, which doesn't try to
# guess whether require is needed or failed,
# see [perl #118561]
die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s
|| $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/;
unless (%{"$base\::"}) {
require Carp;
local $" = " ";
Carp::croak(<<ERROR);
Base class package "$base" is empty.
(Perhaps you need to 'use' the module which defines that package first,
or make that module available in \@INC (\@INC contains: @INC).
ERROR
}
$sigdie = $SIG{__DIE__} || undef;
}
# Make sure a global $SIG{__DIE__} makes it out of the localization.
$SIG{__DIE__} = $sigdie if defined $sigdie;
}
push @bases, $base;
if ( has_fields($base) || has_attr($base) ) {
# No multiple fields inheritance *suck*
if ($fields_base) {
require Carp;
Carp::croak("Can't multiply inherit fields");
} else {
$fields_base = $base;
}
}
}
# Save this until the end so it's all or nothing if the above loop croaks.
push @{"$inheritor\::ISA"}, @bases;
if( defined $fields_base ) {
inherit_fields($inheritor, $fields_base);
}
}
sub inherit_fields {
my($derived, $base) = @_;
return SUCCESS unless $base;
my $battr = get_attr($base);
my $dattr = get_attr($derived);
my $dfields = get_fields($derived);
my $bfields = get_fields($base);
$dattr->[0] = @$battr;
if( keys %$dfields ) {
warn <<"END";
$derived is inheriting from $base but already has its own fields!
This will cause problems. Be sure you use base BEFORE declaring fields.
END
}
# Iterate through the base's fields adding all the non-private
# ones to the derived class. Hang on to the original attribute
# (Public, Private, etc...) and add Inherited.
# This is all too complicated to do efficiently with add_fields().
while (my($k,$v) = each %$bfields) {
my $fno;
if ($fno = $dfields->{$k} and $fno != $v) {
require Carp;
Carp::croak ("Inherited fields can't override existing fields");
}
if( $battr->[$v] & PRIVATE ) {
$dattr->[$v] = PRIVATE | INHERITED;
}
else {
$dattr->[$v] = INHERITED | $battr->[$v];
$dfields->{$k} = $v;
}
}
foreach my $idx (1..$#{$battr}) {
next if defined $dattr->[$idx];
$dattr->[$idx] = $battr->[$idx] & INHERITED;
}
}
1;
__END__

31
vendor/LeOS/tools-leos/common/perl-base/bytes.pm vendored
View File

@ -1,31 +0,0 @@
package bytes;
our $VERSION = '1.05';
$bytes::hint_bits = 0x00000008;
sub import {
$^H |= $bytes::hint_bits;
}
sub unimport {
$^H &= ~$bytes::hint_bits;
}
sub AUTOLOAD {
require "bytes_heavy.pl";
goto &$AUTOLOAD if defined &$AUTOLOAD;
require Carp;
Carp::croak("Undefined subroutine $AUTOLOAD called");
}
sub length (_);
sub chr (_);
sub ord (_);
sub substr ($$;$$);
sub index ($$;$);
sub rindex ($$;$);
1;
__END__

40
vendor/LeOS/tools-leos/common/perl-base/bytes_heavy.pl vendored
View File

@ -1,40 +0,0 @@
package bytes;
sub length (_) {
BEGIN { bytes::import() }
return CORE::length($_[0]);
}
sub substr ($$;$$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::substr($_[0], $_[1]) :
@_ == 3 ? CORE::substr($_[0], $_[1], $_[2]) :
CORE::substr($_[0], $_[1], $_[2], $_[3]) ;
}
sub ord (_) {
BEGIN { bytes::import() }
return CORE::ord($_[0]);
}
sub chr (_) {
BEGIN { bytes::import() }
return CORE::chr($_[0]);
}
sub index ($$;$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::index($_[0], $_[1]) :
CORE::index($_[0], $_[1], $_[2]) ;
}
sub rindex ($$;$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::rindex($_[0], $_[1]) :
CORE::rindex($_[0], $_[1], $_[2]) ;
}
1;

205
vendor/LeOS/tools-leos/common/perl-base/constant.pm vendored
View File

@ -1,205 +0,0 @@
package constant;
use 5.008;
use strict;
use warnings::register;
our $VERSION = '1.33';
our %declared;
#=======================================================================
# Some names are evil choices.
my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
$keywords{UNITCHECK}++ if $] > 5.009;
my %forced_into_main = map +($_, 1),
qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
my %forbidden = (%keywords, %forced_into_main);
my $normal_constant_name = qr/^_?[^\W_0-9]\w*\z/;
my $tolerable = qr/^[A-Za-z_]\w*\z/;
my $boolean = qr/^[01]?\z/;
BEGIN {
# We'd like to do use constant _CAN_PCS => $] > 5.009002
# but that's a bit tricky before we load the constant module :-)
# By doing this, we save several run time checks for *every* call
# to import.
my $const = $] > 5.009002;
my $downgrade = $] < 5.015004; # && $] >= 5.008
my $constarray = exists &_make_const;
if ($const) {
Internals::SvREADONLY($const, 1);
Internals::SvREADONLY($downgrade, 1);
$constant::{_CAN_PCS} = \$const;
$constant::{_DOWNGRADE} = \$downgrade;
$constant::{_CAN_PCS_FOR_ARRAY} = \$constarray;
}
else {
no strict 'refs';
*{"_CAN_PCS"} = sub () {$const};
*{"_DOWNGRADE"} = sub () { $downgrade };
*{"_CAN_PCS_FOR_ARRAY"} = sub () { $constarray };
}
}
#=======================================================================
# import() - import symbols into user's namespace
#
# What we actually do is define a function in the caller's namespace
# which returns the value. The function we create will normally
# be inlined as a constant, thereby avoiding further sub calling
# overhead.
#=======================================================================
sub import {
my $class = shift;
return unless @_; # Ignore 'use constant;'
my $constants;
my $multiple = ref $_[0];
my $caller = caller;
my $flush_mro;
my $symtab;
if (_CAN_PCS) {
no strict 'refs';
$symtab = \%{$caller . '::'};
};
if ( $multiple ) {
if (ref $_[0] ne 'HASH') {
require Carp;
Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
}
$constants = shift;
} else {
unless (defined $_[0]) {
require Carp;
Carp::croak("Can't use undef as constant name");
}
$constants->{+shift} = undef;
}
foreach my $name ( keys %$constants ) {
my $pkg;
my $symtab = $symtab;
my $orig_name = $name;
if ($name =~ s/(.*)(?:::|')(?=.)//s) {
$pkg = $1;
if (_CAN_PCS && $pkg ne $caller) {
no strict 'refs';
$symtab = \%{$pkg . '::'};
}
}
else {
$pkg = $caller;
}
# Normal constant name
if ($name =~ $normal_constant_name and !$forbidden{$name}) {
# Everything is okay
# Name forced into main, but we're not in main. Fatal.
} elsif ($forced_into_main{$name} and $pkg ne 'main') {
require Carp;
Carp::croak("Constant name '$name' is forced into main::");
# Starts with double underscore. Fatal.
} elsif ($name =~ /^__/) {
require Carp;
Carp::croak("Constant name '$name' begins with '__'");
# Maybe the name is tolerable
} elsif ($name =~ $tolerable) {
# Then we'll warn only if you've asked for warnings
if (warnings::enabled()) {
if ($keywords{$name}) {
warnings::warn("Constant name '$name' is a Perl keyword");
} elsif ($forced_into_main{$name}) {
warnings::warn("Constant name '$name' is " .
"forced into package main::");
}
}
# Looks like a boolean
# use constant FRED == fred;
} elsif ($name =~ $boolean) {
require Carp;
if (@_) {
Carp::croak("Constant name '$name' is invalid");
} else {
Carp::croak("Constant name looks like boolean value");
}
} else {
# Must have bad characters
require Carp;
Carp::croak("Constant name '$name' has invalid characters");
}
{
no strict 'refs';
my $full_name = "${pkg}::$name";
$declared{$full_name}++;
if ($multiple || @_ == 1) {
my $scalar = $multiple ? $constants->{$orig_name} : $_[0];
if (_DOWNGRADE) { # for 5.8 to 5.14
# Work around perl bug #31991: Sub names (actually glob
# names in general) ignore the UTF8 flag. So we have to
# turn it off to get the "right" symbol table entry.
utf8::is_utf8 $name and utf8::encode $name;
}
# The constant serves to optimise this entire block out on
# 5.8 and earlier.
if (_CAN_PCS) {
# Use a reference as a proxy for a constant subroutine.
# If this is not a glob yet, it saves space. If it is
# a glob, we must still create it this way to get the
# right internal flags set, as constants are distinct
# from subroutines created with sub(){...}.
# The check in Perl_ck_rvconst knows that inlinable
# constants from cv_const_sv are read only. So we have to:
Internals::SvREADONLY($scalar, 1);
if (!exists $symtab->{$name}) {
$symtab->{$name} = \$scalar;
++$flush_mro->{$pkg};
}
else {
local $constant::{_dummy} = \$scalar;
*$full_name = \&{"_dummy"};
}
} else {
*$full_name = sub () { $scalar };
}
} elsif (@_) {
my @list = @_;
if (_CAN_PCS_FOR_ARRAY) {
_make_const($list[$_]) for 0..$#list;
_make_const(@list);
if (!exists $symtab->{$name}) {
$symtab->{$name} = \@list;
$flush_mro->{$pkg}++;
}
else {
local $constant::{_dummy} = \@list;
*$full_name = \&{"_dummy"};
}
}
else { *$full_name = sub () { @list }; }
} else {
*$full_name = sub () { };
}
}
}
# Flush the cache exactly once if we make any direct symbol table changes.
if (_CAN_PCS && $flush_mro) {
mro::method_changed_in($_) for keys %$flush_mro;
}
}
1;
__END__

152
vendor/LeOS/tools-leos/common/perl-base/feature.pm vendored
View File

@ -1,152 +0,0 @@
# -*- buffer-read-only: t -*-
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by regen/feature.pl.
# Any changes made here will be lost!
package feature;
our $VERSION = '1.47';
our %feature = (
fc => 'feature_fc',
say => 'feature_say',
state => 'feature_state',
switch => 'feature_switch',
bitwise => 'feature_bitwise',
evalbytes => 'feature_evalbytes',
array_base => 'feature_arybase',
signatures => 'feature_signatures',
current_sub => 'feature___SUB__',
refaliasing => 'feature_refaliasing',
postderef_qq => 'feature_postderef_qq',
unicode_eval => 'feature_unieval',
declared_refs => 'feature_myref',
unicode_strings => 'feature_unicode',
);
our %feature_bundle = (
"5.10" => [qw(array_base say state switch)],
"5.11" => [qw(array_base say state switch unicode_strings)],
"5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)],
"5.23" => [qw(current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)],
"all" => [qw(array_base bitwise current_sub declared_refs evalbytes fc postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)],
"default" => [qw(array_base)],
);
$feature_bundle{"5.12"} = $feature_bundle{"5.11"};
$feature_bundle{"5.13"} = $feature_bundle{"5.11"};
$feature_bundle{"5.14"} = $feature_bundle{"5.11"};
$feature_bundle{"5.16"} = $feature_bundle{"5.15"};
$feature_bundle{"5.17"} = $feature_bundle{"5.15"};
$feature_bundle{"5.18"} = $feature_bundle{"5.15"};
$feature_bundle{"5.19"} = $feature_bundle{"5.15"};
$feature_bundle{"5.20"} = $feature_bundle{"5.15"};
$feature_bundle{"5.21"} = $feature_bundle{"5.15"};
$feature_bundle{"5.22"} = $feature_bundle{"5.15"};
$feature_bundle{"5.24"} = $feature_bundle{"5.23"};
$feature_bundle{"5.25"} = $feature_bundle{"5.23"};
$feature_bundle{"5.26"} = $feature_bundle{"5.23"};
$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
my %noops = (
postderef => 1,
lexical_subs => 1,
);
our $hint_shift = 26;
our $hint_mask = 0x1c000000;
our @hint_bundles = qw( default 5.10 5.11 5.15 5.23 );
# This gets set (for now) in $^H as well as in %^H,
# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
# See HINT_UNI_8_BIT in perl.h.
our $hint_uni8bit = 0x00000800;
# TODO:
# - think about versioned features (use feature switch => 2)
sub import {
shift;
if (!@_) {
croak("No features specified");
}
__common(1, @_);
}
sub unimport {
shift;
# A bare C<no feature> should reset to the default bundle
if (!@_) {
$^H &= ~($hint_uni8bit|$hint_mask);
return;
}
__common(0, @_);
}
sub __common {
my $import = shift;
my $bundle_number = $^H & $hint_mask;
my $features = $bundle_number != $hint_mask
&& $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
if ($features) {
# Features are enabled implicitly via bundle hints.
# Delete any keys that may be left over from last time.
delete @^H{ values(%feature) };
$^H |= $hint_mask;
for (@$features) {
$^H{$feature{$_}} = 1;
$^H |= $hint_uni8bit if $_ eq 'unicode_strings';
}
}
while (@_) {
my $name = shift;
if (substr($name, 0, 1) eq ":") {
my $v = substr($name, 1);
if (!exists $feature_bundle{$v}) {
$v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
if (!exists $feature_bundle{$v}) {
unknown_feature_bundle(substr($name, 1));
}
}
unshift @_, @{$feature_bundle{$v}};
next;
}
if (!exists $feature{$name}) {
if (exists $noops{$name}) {
next;
}
unknown_feature($name);
}
if ($import) {
$^H{$feature{$name}} = 1;
$^H |= $hint_uni8bit if $name eq 'unicode_strings';
} else {
delete $^H{$feature{$name}};
$^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
}
}
}
sub unknown_feature {
my $feature = shift;
croak(sprintf('Feature "%s" is not supported by Perl %vd',
$feature, $^V));
}
sub unknown_feature_bundle {
my $feature = shift;
croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
$feature, $^V));
}
sub croak {
require Carp;
Carp::croak(@_);
}
1;
# ex: set ro:

179
vendor/LeOS/tools-leos/common/perl-base/fields.pm vendored
View File

@ -1,179 +0,0 @@
use 5.008;
package fields;
require 5.005;
use strict;
no strict 'refs';
unless( eval q{require warnings::register; warnings::register->import; 1} ) {
*warnings::warnif = sub {
require Carp;
Carp::carp(@_);
}
}
use vars qw(%attr $VERSION);
$VERSION = '2.23';
$VERSION =~ tr/_//d;
# constant.pm is slow
sub PUBLIC () { 2**0 }
sub PRIVATE () { 2**1 }
sub INHERITED () { 2**2 }
sub PROTECTED () { 2**3 }
# The %attr hash holds the attributes of the currently assigned fields
# per class. The hash is indexed by class names and the hash value is
# an array reference. The first element in the array is the lowest field
# number not belonging to a base class. The remaining elements' indices
# are the field numbers. The values are integer bit masks, or undef
# in the case of base class private fields (which occupy a slot but are
# otherwise irrelevant to the class).
sub import {
my $class = shift;
return unless @_;
my $package = caller(0);
# avoid possible typo warnings
%{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
my $fields = \%{"$package\::FIELDS"};
my $fattr = ($attr{$package} ||= [1]);
my $next = @$fattr;
# Quiet pseudo-hash deprecation warning for uses of fields::new.
bless \%{"$package\::FIELDS"}, 'pseudohash';
if ($next > $fattr->[0]
and ($fields->{$_[0]} || 0) >= $fattr->[0])
{
# There are already fields not belonging to base classes.
# Looks like a possible module reload...
$next = $fattr->[0];
}
foreach my $f (@_) {
my $fno = $fields->{$f};
# Allow the module to be reloaded so long as field positions
# have not changed.
if ($fno and $fno != $next) {
require Carp;
if ($fno < $fattr->[0]) {
if ($] < 5.006001) {
warn("Hides field '$f' in base class") if $^W;
} else {
warnings::warnif("Hides field '$f' in base class") ;
}
} else {
Carp::croak("Field name '$f' already in use");
}
}
$fields->{$f} = $next;
$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
$next += 1;
}
if (@$fattr > $next) {
# Well, we gave them the benefit of the doubt by guessing the
# module was reloaded, but they appear to be declaring fields
# in more than one place. We can't be sure (without some extra
# bookkeeping) that the rest of the fields will be declared or
# have the same positions, so punt.
require Carp;
Carp::croak ("Reloaded module must declare all fields at once");
}
}
sub inherit {
require base;
goto &base::inherit_fields;
}
sub _dump # sometimes useful for debugging
{
for my $pkg (sort keys %attr) {
print "\n$pkg";
if (@{"$pkg\::ISA"}) {
print " (", join(", ", @{"$pkg\::ISA"}), ")";
}
print "\n";
my $fields = \%{"$pkg\::FIELDS"};
for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
my $no = $fields->{$f};
print " $no: $f";
my $fattr = $attr{$pkg}[$no];
if (defined $fattr) {
my @a;
push(@a, "public") if $fattr & PUBLIC;
push(@a, "private") if $fattr & PRIVATE;
push(@a, "inherited") if $fattr & INHERITED;
print "\t(", join(", ", @a), ")";
}
print "\n";
}
}
}
if ($] < 5.009) {
*new = sub {
my $class = shift;
$class = ref $class if ref $class;
return bless [\%{$class . "::FIELDS"}], $class;
}
} else {
*new = sub {
my $class = shift;
$class = ref $class if ref $class;
require Hash::Util;
my $self = bless {}, $class;
# The lock_keys() prototype won't work since we require Hash::Util :(
&Hash::Util::lock_keys(\%$self, _accessible_keys($class));
return $self;
}
}
sub _accessible_keys {
my ($class) = @_;
return (
keys %{$class.'::FIELDS'},
map(_accessible_keys($_), @{$class.'::ISA'}),
);
}
sub phash {
die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
my $h;
my $v;
if (@_) {
if (ref $_[0] eq 'ARRAY') {
my $a = shift;
@$h{@$a} = 1 .. @$a;
if (@_) {
$v = shift;
unless (! @_ and ref $v eq 'ARRAY') {
require Carp;
Carp::croak ("Expected at most two array refs\n");
}
}
}
else {
if (@_ % 2) {
require Carp;
Carp::croak ("Odd number of elements initializing pseudo-hash\n");
}
my $i = 0;
@$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
$i = 0;
$v = [grep $i++ % 2, @_];
}
}
else {
$h = {};
$v = [];
}
[ $h, @$v ];
}
1;
__END__

15
vendor/LeOS/tools-leos/common/perl-base/integer.pm vendored
View File

@ -1,15 +0,0 @@
package integer;
our $VERSION = '1.01';
$integer::hint_bits = 0x1;
sub import {
$^H |= $integer::hint_bits;
}
sub unimport {
$^H &= ~$integer::hint_bits;
}
1;

85
vendor/LeOS/tools-leos/common/perl-base/lib.pm vendored
View File

@ -1,85 +0,0 @@
package lib;
# THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
# ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
use Config;
use strict;
my $archname = $Config{archname};
my $version = $Config{version};
my @inc_version_list = reverse split / /, $Config{inc_version_list};
our @ORIG_INC = @INC; # take a handy copy of 'original' value
our $VERSION = '0.64';
sub import {
shift;
my %names;
foreach (reverse @_) {
my $path = $_; # we'll be modifying it, so break the alias
if ($path eq '') {
require Carp;
Carp::carp("Empty compile time value given to use lib");
}
if ($path !~ /\.par$/i && -e $path && ! -d _) {
require Carp;
Carp::carp("Parameter to use lib must be directory, not file");
}
unshift(@INC, $path);
# Add any previous version directories we found at configure time
foreach my $incver (@inc_version_list)
{
my $dir = "$path/$incver";
unshift(@INC, $dir) if -d $dir;
}
# Put a corresponding archlib directory in front of $path if it
# looks like $path has an archlib directory below it.
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
= _get_dirs($path);
unshift(@INC, $arch_dir) if -d $arch_auto_dir;
unshift(@INC, $version_dir) if -d $version_dir;
unshift(@INC, $version_arch_dir) if -d $version_arch_dir;
}
# remove trailing duplicates
@INC = grep { ++$names{$_} == 1 } @INC;
return;
}
sub unimport {
shift;
my %names;
foreach my $path (@_) {
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
= _get_dirs($path);
++$names{$path};
++$names{$arch_dir} if -d $arch_auto_dir;
++$names{$version_dir} if -d $version_dir;
++$names{$version_arch_dir} if -d $version_arch_dir;
}
# Remove ALL instances of each named directory.
@INC = grep { !exists $names{$_} } @INC;
return;
}
sub _get_dirs {
my($dir) = @_;
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
$arch_auto_dir = "$dir/$archname/auto";
$arch_dir = "$dir/$archname";
$version_dir = "$dir/$version";
$version_arch_dir = "$dir/$version/$archname";
return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
}
1;
__END__

102
vendor/LeOS/tools-leos/common/perl-base/locale.pm vendored
View File

@ -1,102 +0,0 @@
package locale;
our $VERSION = '1.09';
use Config;
$Carp::Internal{ (__PACKAGE__) } = 1;
# A separate bit is used for each of the two forms of the pragma, to save
# having to look at %^H for the normal case of a plain 'use locale' without an
# argument.
$locale::hint_bits = 0x4;
$locale::partial_hint_bits = 0x10; # If pragma has an argument
# The pseudo-category :characters consists of 2 real ones; but it also is
# given its own number, -1, because in the complement form it also has the
# side effect of "use feature 'unicode_strings'"
sub import {
shift; # should be 'locale'; not checked
$^H{locale} = 0 unless defined $^H{locale};
if (! @_) { # If no parameter, use the plain form that changes all categories
$^H |= $locale::hint_bits;
}
else {
my @categories = ( qw(:ctype :collate :messages
:numeric :monetary :time) );
for (my $i = 0; $i < @_; $i++) {
my $arg = $_[$i];
$complement = $arg =~ s/ : ( ! | not_ ) /:/x;
if (! grep { $arg eq $_ } @categories, ":characters") {
require Carp;
Carp::croak("Unknown parameter '$_[$i]' to 'use locale'");
}
if ($complement) {
if ($i != 0 || $i < @_ - 1) {
require Carp;
Carp::croak("Only one argument to 'use locale' allowed"
. "if is $complement");
}
if ($arg eq ':characters') {
push @_, grep { $_ ne ':ctype' && $_ ne ':collate' }
@categories;
# We add 1 to the category number; This category number
# is -1
$^H{locale} |= (1 << 0);
}
else {
push @_, grep { $_ ne $arg } @categories;
}
next;
}
elsif ($arg eq ':characters') {
push @_, ':ctype', ':collate';
next;
}
$^H |= $locale::partial_hint_bits;
# This form of the pragma overrides the other
$^H &= ~$locale::hint_bits;
$arg =~ s/^://;
eval { require POSIX; import POSIX 'locale_h'; };
# Map our names to the ones defined by POSIX
my $LC = "LC_" . uc($arg);
my $bit = eval "&POSIX::$LC";
if (defined $bit) { # XXX Should we warn that this category isn't
# supported on this platform, or make it
# always be the C locale?
# Verify our assumption.
if (! ($bit >= 0 && $bit < 31)) {
require Carp;
Carp::croak("Cannot have ':$arg' parameter to 'use locale'"
. " on this platform. Use the 'perlbug' utility"
. " to report this problem, or send email to"
. " 'perlbug\@perl.org'. $LC=$bit");
}
# 1 is added so that the pseudo-category :characters, which is
# -1, comes out 0.
$^H{locale} |= 1 << ($bit + 1);
}
}
}
}
sub unimport {
$^H &= ~($locale::hint_bits|$locale::partial_hint_bits);
$^H{locale} = 0;
}
1;

181
vendor/LeOS/tools-leos/common/perl-base/overload.pm vendored
View File

@ -1,181 +0,0 @@
package overload;
our $VERSION = '1.28';
%ops = (
with_assign => "+ - * / % ** << >> x .",
assign => "+= -= *= /= %= **= <<= >>= x= .=",
num_comparison => "< <= > >= == !=",
'3way_comparison' => "<=> cmp",
str_comparison => "lt le gt ge eq ne",
binary => '& &= | |= ^ ^= &. &.= |. |.= ^. ^.=',
unary => "neg ! ~ ~.",
mutators => '++ --',
func => "atan2 cos sin exp abs log sqrt int",
conversion => 'bool "" 0+ qr',
iterators => '<>',
filetest => "-X",
dereferencing => '${} @{} %{} &{} *{}',
matching => '~~',
special => 'nomethod fallback =',
);
my %ops_seen;
@ops_seen{ map split(/ /), values %ops } = ();
sub nil {}
sub OVERLOAD {
$package = shift;
my %arg = @_;
my $sub;
*{$package . "::(("} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
if ($_ eq 'fallback') {
for my $sym (*{$package . "::()"}) {
*$sym = \&nil; # Make it findable via fetchmethod.
$$sym = $arg{$_};
}
} else {
warnings::warnif("overload arg '$_' is invalid")
unless exists $ops_seen{$_};
$sub = $arg{$_};
if (not ref $sub) {
$ {$package . "::(" . $_} = $sub;
$sub = \&nil;
}
#print STDERR "Setting '$ {'package'}::\cO$_' to \\&'$sub'.\n";
*{$package . "::(" . $_} = \&{ $sub };
}
}
}
sub import {
$package = (caller())[0];
# *{$package . "::OVERLOAD"} = \&OVERLOAD;
shift;
$package->overload::OVERLOAD(@_);
}
sub unimport {
$package = (caller())[0];
shift;
*{$package . "::(("} = \&nil;
for (@_) {
warnings::warnif("overload arg '$_' is invalid")
unless exists $ops_seen{$_};
delete $ {$package . "::"}{$_ eq 'fallback' ? '()' : "(" .$_};
}
}
sub Overloaded {
my $package = shift;
$package = ref $package if ref $package;
mycan ($package, '()') || mycan ($package, '((');
}
sub ov_method {
my $globref = shift;
return undef unless $globref;
my $sub = \&{*$globref};
no overloading;
return $sub if $sub != \&nil;
return shift->can($ {*$globref});
}
sub OverloadedStringify {
my $package = shift;
$package = ref $package if ref $package;
#$package->can('(""')
ov_method mycan($package, '(""'), $package
or ov_method mycan($package, '(0+'), $package
or ov_method mycan($package, '(bool'), $package
or ov_method mycan($package, '(nomethod'), $package;
}
sub Method {
my $package = shift;
if(ref $package) {
local $@;
local $!;
require Scalar::Util;
$package = Scalar::Util::blessed($package);
return undef if !defined $package;
}
#my $meth = $package->can('(' . shift);
ov_method mycan($package, '(' . shift), $package;
#return $meth if $meth ne \&nil;
#return $ {*{$meth}};
}
sub AddrRef {
no overloading;
"$_[0]";
}
*StrVal = *AddrRef;
sub mycan { # Real can would leave stubs.
my ($package, $meth) = @_;
local $@;
local $!;
require mro;
my $mro = mro::get_linear_isa($package);
foreach my $p (@$mro) {
my $fqmeth = $p . q{::} . $meth;
return \*{$fqmeth} if defined &{$fqmeth};
}
return undef;
}
%constants = (
'integer' => 0x1000, # HINT_NEW_INTEGER
'float' => 0x2000, # HINT_NEW_FLOAT
'binary' => 0x4000, # HINT_NEW_BINARY
'q' => 0x8000, # HINT_NEW_STRING
'qr' => 0x10000, # HINT_NEW_RE
);
use warnings::register;
sub constant {
# Arguments: what, sub
while (@_) {
if (@_ == 1) {
warnings::warnif ("Odd number of arguments for overload::constant");
last;
}
elsif (!exists $constants {$_ [0]}) {
warnings::warnif ("'$_[0]' is not an overloadable type");
}
elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) {
# Can't use C<ref $_[1] eq "CODE"> above as code references can be
# blessed, and C<ref> would return the package the ref is blessed into.
if (warnings::enabled) {
$_ [1] = "undef" unless defined $_ [1];
warnings::warn ("'$_[1]' is not a code reference");
}
}
else {
$^H{$_[0]} = $_[1];
$^H |= $constants{$_[0]};
}
shift, shift;
}
}
sub remove_constant {
# Arguments: what, sub
while (@_) {
delete $^H{$_[0]};
$^H &= ~ $constants{$_[0]};
shift, shift;
}
}
1;
__END__

53
vendor/LeOS/tools-leos/common/perl-base/overloading.pm vendored
View File

@ -1,53 +0,0 @@
package overloading;
use warnings;
our $VERSION = '0.02';
my $HINT_NO_AMAGIC = 0x01000000; # see perl.h
require 5.010001;
sub _ops_to_nums {
require overload::numbers;
map { exists $overload::numbers::names{"($_"}
? $overload::numbers::names{"($_"}
: do { require Carp; Carp::croak("'$_' is not a valid overload") }
} @_;
}
sub import {
my ( $class, @ops ) = @_;
if ( @ops ) {
if ( $^H{overloading} ) {
vec($^H{overloading} , $_, 1) = 0 for _ops_to_nums(@ops);
}
if ( $^H{overloading} !~ /[^\0]/ ) {
delete $^H{overloading};
$^H &= ~$HINT_NO_AMAGIC;
}
} else {
delete $^H{overloading};
$^H &= ~$HINT_NO_AMAGIC;
}
}
sub unimport {
my ( $class, @ops ) = @_;
if ( exists $^H{overloading} or not $^H & $HINT_NO_AMAGIC ) {
if ( @ops ) {
vec($^H{overloading} ||= '', $_, 1) = 1 for _ops_to_nums(@ops);
} else {
delete $^H{overloading};
}
}
$^H |= $HINT_NO_AMAGIC;
}
1;
__END__

29
vendor/LeOS/tools-leos/common/perl-base/parent.pm vendored
View File

@ -1,29 +0,0 @@
package parent;
use strict;
use vars qw($VERSION);
$VERSION = '0.236';
sub import {
my $class = shift;
my $inheritor = caller(0);
if ( @_ and $_[0] eq '-norequire' ) {
shift @_;
} else {
for ( my @filename = @_ ) {
s{::|'}{/}g;
require "$_.pm"; # dies if the file is not found
}
}
{
no strict 'refs';
push @{"$inheritor\::ISA"}, @_; # dies if a loop is detected
};
};
1;
__END__

287
vendor/LeOS/tools-leos/common/perl-base/re.pm vendored
View File

@ -1,287 +0,0 @@
package re;
# pragma for controlling the regexp engine
use strict;
use warnings;
our $VERSION = "0.34";
our @ISA = qw(Exporter);
our @EXPORT_OK = ('regmust',
qw(is_regexp regexp_pattern
regname regnames regnames_count));
our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
my %bitmask = (
taint => 0x00100000, # HINT_RE_TAINT
eval => 0x00200000, # HINT_RE_EVAL
);
my $flags_hint = 0x02000000; # HINT_RE_FLAGS
my $PMMOD_SHIFT = 0;
my %reflags = (
m => 1 << ($PMMOD_SHIFT + 0),
s => 1 << ($PMMOD_SHIFT + 1),
i => 1 << ($PMMOD_SHIFT + 2),
x => 1 << ($PMMOD_SHIFT + 3),
xx => 1 << ($PMMOD_SHIFT + 4),
n => 1 << ($PMMOD_SHIFT + 5),
p => 1 << ($PMMOD_SHIFT + 6),
strict => 1 << ($PMMOD_SHIFT + 10),
# special cases:
d => 0,
l => 1,
u => 2,
a => 3,
aa => 4,
);
sub setcolor {
eval { # Ignore errors
require Term::Cap;
my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
my @props = split /,/, $props;
my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
$colors =~ s/\0//g;
$ENV{PERL_RE_COLORS} = $colors;
};
if ($@) {
$ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
}
}
my %flags = (
COMPILE => 0x0000FF,
PARSE => 0x000001,
OPTIMISE => 0x000002,
TRIEC => 0x000004,
DUMP => 0x000008,
FLAGS => 0x000010,
TEST => 0x000020,
EXECUTE => 0x00FF00,
INTUIT => 0x000100,
MATCH => 0x000200,
TRIEE => 0x000400,
EXTRA => 0xFF0000,
TRIEM => 0x010000,
OFFSETS => 0x020000,
OFFSETSDBG => 0x040000,
STATE => 0x080000,
OPTIMISEM => 0x100000,
STACK => 0x280000,
BUFFERS => 0x400000,
GPOS => 0x800000,
);
$flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS};
$flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
$flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
$flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
if (defined &DynaLoader::boot_DynaLoader) {
require XSLoader;
XSLoader::load();
}
# else we're miniperl
# We need to work for miniperl, because the XS toolchain uses Text::Wrap, which
# uses re 'taint'.
sub _load_unload {
my ($on)= @_;
if ($on) {
# We call install() every time, as if we didn't, we wouldn't
# "see" any changes to the color environment var since
# the last time it was called.
# install() returns an integer, which if casted properly
# in C resolves to a structure containing the regexp
# hooks. Setting it to a random integer will guarantee
# segfaults.
$^H{regcomp} = install();
} else {
delete $^H{regcomp};
}
}
sub bits {
my $on = shift;
my $bits = 0;
my $turning_all_off = ! @_ && ! $on;
if ($turning_all_off) {
# Pretend were called with certain parameters, which are best dealt
# with that way.
push @_, keys %bitmask; # taint and eval
push @_, 'strict';
}
# Process each subpragma parameter
ARG:
foreach my $idx (0..$#_){
my $s=$_[$idx];
if ($s eq 'Debug' or $s eq 'Debugcolor') {
setcolor() if $s =~/color/i;
${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
for my $idx ($idx+1..$#_) {
if ($flags{$_[$idx]}) {
if ($on) {
${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
} else {
${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
}
} else {
require Carp;
Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
join(", ",sort keys %flags ) );
}
}
_load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
last;
} elsif ($s eq 'debug' or $s eq 'debugcolor') {
setcolor() if $s =~/color/i;
_load_unload($on);
last;
} elsif (exists $bitmask{$s}) {
$bits |= $bitmask{$s};
} elsif ($EXPORT_OK{$s}) {
require Exporter;
re->export_to_level(2, 're', $s);
} elsif ($s eq 'strict') {
if ($on) {
$^H{reflags} |= $reflags{$s};
warnings::warnif('experimental::re_strict',
"\"use re 'strict'\" is experimental");
# Turn on warnings if not already done.
if (! warnings::enabled('regexp')) {
require warnings;
warnings->import('regexp');
$^H{re_strict} = 1;
}
}
else {
$^H{reflags} &= ~$reflags{$s} if $^H{reflags};
# Turn off warnings if we turned them on.
warnings->unimport('regexp') if $^H{re_strict};
}
if ($^H{reflags}) {
$^H |= $flags_hint;
}
else {
$^H &= ~$flags_hint;
}
} elsif ($s =~ s/^\///) {
my $reflags = $^H{reflags} || 0;
my $seen_charset;
my $x_count = 0;
while ($s =~ m/( . )/gx) {
local $_ = $1;
if (/[adul]/) {
# The 'a' may be repeated; hide this from the rest of the
# code by counting and getting rid of all of them, then
# changing to 'aa' if there is a repeat.
if ($_ eq 'a') {
my $sav_pos = pos $s;
my $a_count = $s =~ s/a//g;
pos $s = $sav_pos - 1; # -1 because got rid of the 'a'
if ($a_count > 2) {
require Carp;
Carp::carp(
qq 'The "a" flag may only appear a maximum of twice'
);
}
elsif ($a_count == 2) {
$_ = 'aa';
}
}
if ($on) {
if ($seen_charset) {
require Carp;
if ($seen_charset ne $_) {
Carp::carp(
qq 'The "$seen_charset" and "$_" flags '
.qq 'are exclusive'
);
}
else {
Carp::carp(
qq 'The "$seen_charset" flag may not appear '
.qq 'twice'
);
}
}
$^H{reflags_charset} = $reflags{$_};
$seen_charset = $_;
}
else {
delete $^H{reflags_charset}
if defined $^H{reflags_charset}
&& $^H{reflags_charset} == $reflags{$_};
}
} elsif (exists $reflags{$_}) {
if ($_ eq 'x') {
$x_count++;
if ($x_count > 2) {
require Carp;
Carp::carp(
qq 'The "x" flag may only appear a maximum of twice'
);
}
elsif ($x_count == 2) {
$_ = 'xx'; # First time through got the /x
}
}
$on
? $reflags |= $reflags{$_}
: ($reflags &= ~$reflags{$_});
} else {
require Carp;
Carp::carp(
qq'Unknown regular expression flag "$_"'
);
next ARG;
}
}
($^H{reflags} = $reflags or defined $^H{reflags_charset})
? $^H |= $flags_hint
: ($^H &= ~$flags_hint);
} else {
require Carp;
Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
")");
}
}
if ($turning_all_off) {
_load_unload(0);
$^H{reflags} = 0;
$^H{reflags_charset} = 0;
$^H &= ~$flags_hint;
}
$bits;
}
sub import {
shift;
$^H |= bits(1, @_);
}
sub unimport {
shift;
$^H &= ~ bits(0, @_);
}
1;
__END__

184
vendor/LeOS/tools-leos/common/perl-base/strict.pm vendored
View File

@ -1,184 +0,0 @@
package strict;
$strict::VERSION = "1.11";
my ( %bitmask, %explicit_bitmask );
BEGIN {
# Verify that we're called correctly so that strictures will work.
# Can't use Carp, since Carp uses us!
# see also warnings.pm.
die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' )
&& __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
%bitmask = (
refs => 0x00000002,
subs => 0x00000200,
vars => 0x00000400,
);
%explicit_bitmask = (
refs => 0x00000020,
subs => 0x00000040,
vars => 0x00000080,
);
my $bits = 0;
$bits |= $_ for values %bitmask;
my $inline_all_bits = $bits;
*all_bits = sub () { $inline_all_bits };
$bits = 0;
$bits |= $_ for values %explicit_bitmask;
my $inline_all_explicit_bits = $bits;
*all_explicit_bits = sub () { $inline_all_explicit_bits };
}
sub bits {
my $bits = 0;
my @wrong;
foreach my $s (@_) {
if (exists $bitmask{$s}) {
$^H |= $explicit_bitmask{$s};
$bits |= $bitmask{$s};
}
else {
push @wrong, $s;
}
}
if (@wrong) {
require Carp;
Carp::croak("Unknown 'strict' tag(s) '@wrong'");
}
$bits;
}
sub import {
shift;
$^H |= @_ ? &bits : all_bits | all_explicit_bits;
}
sub unimport {
shift;
if (@_) {
$^H &= ~&bits;
}
else {
$^H &= ~all_bits;
$^H |= all_explicit_bits;
}
}
1;
__END__
=head1 NAME
strict - Perl pragma to restrict unsafe constructs
=head1 SYNOPSIS
use strict;
use strict "vars";
use strict "refs";
use strict "subs";
use strict;
no strict "vars";
=head1 DESCRIPTION
The C<strict> pragma disables certain Perl expressions that could behave
unexpectedly or are difficult to debug, turning them into errors. The
effect of this pragma is limited to the current file or scope block.
If no import list is supplied, all possible restrictions are assumed.
(This is the safest mode to operate in, but is sometimes too strict for
casual programming.) Currently, there are three possible things to be
strict about: "subs", "vars", and "refs".
=over 6
=item C<strict refs>
This generates a runtime error if you
use symbolic references (see L<perlref>).
use strict 'refs';
$ref = \$foo;
print $$ref; # ok
$ref = "foo";
print $$ref; # runtime error; normally ok
$file = "STDOUT";
print $file "Hi!"; # error; note: no comma after $file
There is one exception to this rule:
$bar = \&{'foo'};
&$bar;
is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
=item C<strict vars>
This generates a compile-time error if you access a variable that was
neither explicitly declared (using any of C<my>, C<our>, C<state>, or C<use
vars>) nor fully qualified. (Because this is to avoid variable suicide
problems and subtle dynamic scoping issues, a merely C<local> variable isn't
good enough.) See L<perlfunc/my>, L<perlfunc/our>, L<perlfunc/state>,
L<perlfunc/local>, and L<vars>.
use strict 'vars';
$X::foo = 1; # ok, fully qualified
my $foo = 10; # ok, my() var
local $baz = 9; # blows up, $baz not declared before
package Cinna;
our $bar; # Declares $bar in current package
$bar = 'HgS'; # ok, global declared via pragma
The local() generated a compile-time error because you just touched a global
name without fully qualifying it.
Because of their special use by sort(), the variables $a and $b are
exempted from this check.
=item C<strict subs>
This disables the poetry optimization, generating a compile-time error if
you try to use a bareword identifier that's not a subroutine, unless it
is a simple identifier (no colons) and that it appears in curly braces or
on the left hand side of the C<< => >> symbol.
use strict 'subs';
$SIG{PIPE} = Plumber; # blows up
$SIG{PIPE} = "Plumber"; # fine: quoted string is always ok
$SIG{PIPE} = \&Plumber; # preferred form
=back
See L<perlmodlib/Pragmatic Modules>.
=head1 HISTORY
C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted
compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or
inside curlies), but without forcing it always to a literal string.
Starting with Perl 5.8.1 strict is strict about its restrictions:
if unknown restrictions are used, the strict pragma will abort with
Unknown 'strict' tag(s) '...'
As of version 1.04 (Perl 5.10), strict verifies that it is used as
"strict" to avoid the dreaded Strict trap on case insensitive file
systems.
=cut

6938
vendor/LeOS/tools-leos/common/perl-base/unicore/Heavy.pl vendored
View File

File diff suppressed because it is too large Load Diff

1382
vendor/LeOS/tools-leos/common/perl-base/unicore/To/Age.pl vendored
View File

File diff suppressed because it is too large Load Diff

648
vendor/LeOS/tools-leos/common/perl-base/unicore/To/Bc.pl vendored
View File

@ -1,648 +0,0 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBc'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToBc'}{'missing'} = 'L';
return <<'END';
0 8 BN
9 S
A B
B S
C WS
D B
E 1B BN
1C 1E B
1F S
20 WS
21 22 ON
23 25 ET
26 2A ON
2B ES
2C CS
2D ES
2E 2F CS
30 39 EN
3A CS
3B 40 ON
5B 60 ON
7B 7E ON
7F 84 BN
85 B
86 9F BN
A0 CS
A1 ON
A2 A5 ET
A6 A9 ON
AB AC ON
AD BN
AE AF ON
B0 B1 ET
B2 B3 EN
B4 ON
B6 B8 ON
B9 EN
BB BF ON
D7 ON
F7 ON
2B9 2BA ON
2C2 2CF ON
2D2 2DF ON
2E5 2ED ON
2EF 2FF ON
300 36F NSM
374 375 ON
37E ON
384 385 ON
387 ON
3F6 ON
483 489 NSM
58A ON
58D 58E ON
58F ET
590 R
591 5BD NSM
5BE R
5BF NSM
5C0 R
5C1 5C2 NSM
5C3 R
5C4 5C5 NSM
5C6 R
5C7 NSM
5C8 5FF R
600 605 AN
606 607 ON
608 AL
609 60A ET
60B AL
60C CS
60D AL
60E 60F ON
610 61A NSM
61B 64A AL
64B 65F NSM
660 669 AN
66A ET
66B 66C AN
66D 66F AL
670 NSM
671 6D5 AL
6D6 6DC NSM
6DD AN
6DE ON
6DF 6E4 NSM
6E5 6E6 AL
6E7 6E8 NSM
6E9 ON
6EA 6ED NSM
6EE 6EF AL
6F0 6F9 EN
6FA 710 AL
711 NSM
712 72F AL
730 74A NSM
74B 7A5 AL
7A6 7B0 NSM
7B1 7BF AL
7C0 7EA R
7EB 7F3 NSM
7F4 7F5 R
7F6 7F9 ON
7FA 815 R
816 819 NSM
81A R
81B 823 NSM
824 R
825 827 NSM
828 R
829 82D NSM
82E 858 R
859 85B NSM
85C 89F R
8A0 8D3 AL
8D4 8E1 NSM
8E2 AN
8E3 902 NSM
93A NSM
93C NSM
941 948 NSM
94D NSM
951 957 NSM
962 963 NSM
981 NSM
9BC NSM
9C1 9C4 NSM
9CD NSM
9E2 9E3 NSM
9F2 9F3 ET
9FB ET
A01 A02 NSM
A3C NSM
A41 A42 NSM
A47 A48 NSM
A4B A4D NSM
A51 NSM
A70 A71 NSM
A75 NSM
A81 A82 NSM
ABC NSM
AC1 AC5 NSM
AC7 AC8 NSM
ACD NSM
AE2 AE3 NSM
AF1 ET
B01 NSM
B3C NSM
B3F NSM
B41 B44 NSM
B4D NSM
B56 NSM
B62 B63 NSM
B82 NSM
BC0 NSM
BCD NSM
BF3 BF8 ON
BF9 ET
BFA ON
C00 NSM
C3E C40 NSM
C46 C48 NSM
C4A C4D NSM
C55 C56 NSM
C62 C63 NSM
C78 C7E ON
C81 NSM
CBC NSM
CCC CCD NSM
CE2 CE3 NSM
D01 NSM
D41 D44 NSM
D4D NSM
D62 D63 NSM
DCA NSM
DD2 DD4 NSM
DD6 NSM
E31 NSM
E34 E3A NSM
E3F ET
E47 E4E NSM
EB1 NSM
EB4 EB9 NSM
EBB EBC NSM
EC8 ECD NSM
F18 F19 NSM
F35 NSM
F37 NSM
F39 NSM
F3A F3D ON
F71 F7E NSM
F80 F84 NSM
F86 F87 NSM
F8D F97 NSM
F99 FBC NSM
FC6 NSM
102D 1030 NSM
1032 1037 NSM
1039 103A NSM
103D 103E NSM
1058 1059 NSM
105E 1060 NSM
1071 1074 NSM
1082 NSM
1085 1086 NSM
108D NSM
109D NSM
135D 135F NSM
1390 1399 ON
1400 ON
1680 WS
169B 169C ON
1712 1714 NSM
1732 1734 NSM
1752 1753 NSM
1772 1773 NSM
17B4 17B5 NSM
17B7 17BD NSM
17C6 NSM
17C9 17D3 NSM
17DB ET
17DD NSM
17F0 17F9 ON
1800 180A ON
180B 180D NSM
180E BN
1885 1886 NSM
18A9 NSM
1920 1922 NSM
1927 1928 NSM
1932 NSM
1939 193B NSM
1940 ON
1944 1945 ON
19DE 19FF ON
1A17 1A18 NSM
1A1B NSM
1A56 NSM
1A58 1A5E NSM
1A60 NSM
1A62 NSM
1A65 1A6C NSM
1A73 1A7C NSM
1A7F NSM
1AB0 1ABE NSM
1B00 1B03 NSM
1B34 NSM
1B36 1B3A NSM
1B3C NSM
1B42 NSM
1B6B 1B73 NSM
1B80 1B81 NSM
1BA2 1BA5 NSM
1BA8 1BA9 NSM
1BAB 1BAD NSM
1BE6 NSM
1BE8 1BE9 NSM
1BED NSM
1BEF 1BF1 NSM
1C2C 1C33 NSM
1C36 1C37 NSM
1CD0 1CD2 NSM
1CD4 1CE0 NSM
1CE2 1CE8 NSM
1CED NSM
1CF4 NSM
1CF8 1CF9 NSM
1DC0 1DF5 NSM
1DFB 1DFF NSM
1FBD ON
1FBF 1FC1 ON
1FCD 1FCF ON
1FDD 1FDF ON
1FED 1FEF ON
1FFD 1FFE ON
2000 200A WS
200B 200D BN
200F R
2010 2027 ON
2028 WS
2029 B
202A LRE
202B RLE
202C PDF
202D LRO
202E RLO
202F CS
2030 2034 ET
2035 2043 ON
2044 CS
2045 205E ON
205F WS
2060 2065 BN
2066 LRI
2067 RLI
2068 FSI
2069 PDI
206A 206F BN
2070 EN
2074 2079 EN
207A 207B ES
207C 207E ON
2080 2089 EN
208A 208B ES
208C 208E ON
20A0 20CF ET
20D0 20F0 NSM
2100 2101 ON
2103 2106 ON
2108 2109 ON
2114 ON
2116 2118 ON
211E 2123 ON
2125 ON
2127 ON
2129 ON
212E ET
213A 213B ON
2140 2144 ON
214A 214D ON
2150 215F ON
2189 218B ON
2190 2211 ON
2212 ES
2213 ET
2214 2335 ON
237B 2394 ON
2396 23FE ON
2400 2426 ON
2440 244A ON
2460 2487 ON
2488 249B EN
24EA 26AB ON
26AD 27FF ON
2900 2B73 ON
2B76 2B95 ON
2B98 2BB9 ON
2BBD 2BC8 ON
2BCA 2BD1 ON
2BEC 2BEF ON
2CE5 2CEA ON
2CEF 2CF1 NSM
2CF9 2CFF ON
2D7F NSM
2DE0 2DFF NSM
2E00 2E44 ON
2E80 2E99 ON
2E9B 2EF3 ON
2F00 2FD5 ON
2FF0 2FFB ON
3000 WS
3001 3004 ON
3008 3020 ON
302A 302D NSM
3030 ON
3036 3037 ON
303D 303F ON
3099 309A NSM
309B 309C ON
30A0 ON
30FB ON
31C0 31E3 ON
321D 321E ON
3250 325F ON
327C 327E ON
32B1 32BF ON
32CC 32CF ON
3377 337A ON
33DE 33DF ON
33FF ON
4DC0 4DFF ON
A490 A4C6 ON
A60D A60F ON
A66F A672 NSM
A673 ON
A674 A67D NSM
A67E A67F ON
A69E A69F NSM
A6F0 A6F1 NSM
A700 A721 ON
A788 ON
A802 NSM
A806 NSM
A80B NSM
A825 A826 NSM
A828 A82B ON
A838 A839 ET
A874 A877 ON
A8C4 A8C5 NSM
A8E0 A8F1 NSM
A926 A92D NSM
A947 A951 NSM
A980 A982 NSM
A9B3 NSM
A9B6 A9B9 NSM
A9BC NSM
A9E5 NSM
AA29 AA2E NSM
AA31 AA32 NSM
AA35 AA36 NSM
AA43 NSM
AA4C NSM
AA7C NSM
AAB0 NSM
AAB2 AAB4 NSM
AAB7 AAB8 NSM
AABE AABF NSM
AAC1 NSM
AAEC AAED NSM
AAF6 NSM
ABE5 NSM
ABE8 NSM
ABED NSM
FB1D R
FB1E NSM
FB1F FB28 R
FB29 ES
FB2A FB4F R
FB50 FD3D AL
FD3E FD3F ON
FD40 FDCF AL
FDD0 FDEF BN
FDF0 FDFC AL
FDFD ON
FDFE FDFF AL
FE00 FE0F NSM
FE10 FE19 ON
FE20 FE2F NSM
FE30 FE4F ON
FE50 CS
FE51 ON
FE52 CS
FE54 ON
FE55 CS
FE56 FE5E ON
FE5F ET
FE60 FE61 ON
FE62 FE63 ES
FE64 FE66 ON
FE68 ON
FE69 FE6A ET
FE6B ON
FE70 FEFE AL
FEFF BN
FF01 FF02 ON
FF03 FF05 ET
FF06 FF0A ON
FF0B ES
FF0C CS
FF0D ES
FF0E FF0F CS
FF10 FF19 EN
FF1A CS
FF1B FF20 ON
FF3B FF40 ON
FF5B FF65 ON
FFE0 FFE1 ET
FFE2 FFE4 ON
FFE5 FFE6 ET
FFE8 FFEE ON
FFF0 FFF8 BN
FFF9 FFFD ON
FFFE FFFF BN
10101 ON
10140 1018C ON
10190 1019B ON
101A0 ON
101FD NSM
102E0 NSM
102E1 102FB EN
10376 1037A NSM
10800 1091E R
1091F ON
10920 10A00 R
10A01 10A03 NSM
10A04 R
10A05 10A06 NSM
10A07 10A0B R
10A0C 10A0F NSM
10A10 10A37 R
10A38 10A3A NSM
10A3B 10A3E R
10A3F NSM
10A40 10AE4 R
10AE5 10AE6 NSM
10AE7 10B38 R
10B39 10B3F ON
10B40 10E5F R
10E60 10E7E AN
10E7F 10FFF R
11001 NSM
11038 11046 NSM
11052 11065 ON
1107F 11081 NSM
110B3 110B6 NSM
110B9 110BA NSM
11100 11102 NSM
11127 1112B NSM
1112D 11134 NSM
11173 NSM
11180 11181 NSM
111B6 111BE NSM
111CA 111CC NSM
1122F 11231 NSM
11234 NSM
11236 11237 NSM
1123E NSM
112DF NSM
112E3 112EA NSM
11300 11301 NSM
1133C NSM
11340 NSM
11366 1136C NSM
11370 11374 NSM
11438 1143F NSM
11442 11444 NSM
11446 NSM
114B3 114B8 NSM
114BA NSM
114BF 114C0 NSM
114C2 114C3 NSM
115B2 115B5 NSM
115BC 115BD NSM
115BF 115C0 NSM
115DC 115DD NSM
11633 1163A NSM
1163D NSM
1163F 11640 NSM
11660 1166C ON
116AB NSM
116AD NSM
116B0 116B5 NSM
116B7 NSM
1171D 1171F NSM
11722 11725 NSM
11727 1172B NSM
11C30 11C36 NSM
11C38 11C3D NSM
11C92 11CA7 NSM
11CAA 11CB0 NSM
11CB2 11CB3 NSM
11CB5 11CB6 NSM
16AF0 16AF4 NSM
16B30 16B36 NSM
16F8F 16F92 NSM
1BC9D 1BC9E NSM
1BCA0 1BCA3 BN
1D167 1D169 NSM
1D173 1D17A BN
1D17B 1D182 NSM
1D185 1D18B NSM
1D1AA 1D1AD NSM
1D200 1D241 ON
1D242 1D244 NSM
1D245 ON
1D300 1D356 ON
1D6DB ON
1D715 ON
1D74F ON
1D789 ON
1D7C3 ON
1D7CE 1D7FF EN
1DA00 1DA36 NSM
1DA3B 1DA6C NSM
1DA75 NSM
1DA84 NSM
1DA9B 1DA9F NSM
1DAA1 1DAAF NSM
1E000 1E006 NSM
1E008 1E018 NSM
1E01B 1E021 NSM
1E023 1E024 NSM
1E026 1E02A NSM
1E800 1E8CF R
1E8D0 1E8D6 NSM
1E8D7 1E943 R
1E944 1E94A NSM
1E94B 1EDFF R
1EE00 1EEEF AL
1EEF0 1EEF1 ON
1EEF2 1EEFF AL
1EF00 1EFFF R
1F000 1F02B ON
1F030 1F093 ON
1F0A0 1F0AE ON
1F0B1 1F0BF ON
1F0C1 1F0CF ON
1F0D1 1F0F5 ON
1F100 1F10A EN
1F10B 1F10C ON
1F16A 1F16B ON
1F300 1F6D2 ON
1F6E0 1F6EC ON
1F6F0 1F6F6 ON
1F700 1F773 ON
1F780 1F7D4 ON
1F800 1F80B ON
1F810 1F847 ON
1F850 1F859 ON
1F860 1F887 ON
1F890 1F8AD ON
1F910 1F91E ON
1F920 1F927 ON
1F930 ON
1F933 1F93E ON
1F940 1F94B ON
1F950 1F95E ON
1F980 1F991 ON
1F9C0 ON
1FFFE 1FFFF BN
2FFFE 2FFFF BN
3FFFE 3FFFF BN
4FFFE 4FFFF BN
5FFFE 5FFFF BN
6FFFE 6FFFF BN
7FFFE 7FFFF BN
8FFFE 8FFFF BN
9FFFE 9FFFF BN
AFFFE AFFFF BN
BFFFE BFFFF BN
CFFFE CFFFF BN
DFFFE E00FF BN
E0100 E01EF NSM
E01F0 E0FFF BN
EFFFE EFFFF BN
FFFFE FFFFF BN
10FFFE 10FFFF BN
END

388
vendor/LeOS/tools-leos/common/perl-base/unicore/To/Bmg.pl vendored
View File

@ -1,388 +0,0 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! IT IS DEPRECATED TO USE THIS FILE !!!!!!!
# This file is for internal use by core Perl only. It is retained for
# backwards compatibility with applications that may have come to rely on it,
# but its format and even its name or existence are subject to change without
# notice in a future Perl version. Don't use it directly. Instead, its
# contents are now retrievable through a stable API in the Unicode::UCD
# module: Unicode::UCD::prop_invmap('Bidi_Mirroring_Glyph') (Values for individual
# code points can be retrieved via Unicode::UCD::charprop());
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBmg'}{'format'} = 'x'; # non-negative hex whole number; a code point
$utf8::SwashInfo{'ToBmg'}{'missing'} = ''; # code point maps to the null string
return <<'END';
0028 0029
0029 0028
003C 003E
003E 003C
005B 005D
005D 005B
007B 007D
007D 007B
00AB 00BB
00BB 00AB
0F3A 0F3B
0F3B 0F3A
0F3C 0F3D
0F3D 0F3C
169B 169C
169C 169B
2039 203A
203A 2039
2045 2046
2046 2045
207D 207E
207E 207D
208D 208E
208E 208D
2208 220B
2209 220C
220A 220D
220B 2208
220C 2209
220D 220A
2215 29F5
223C 223D
223D 223C
2243 22CD
2252 2253
2253 2252
2254 2255
2255 2254
2264 2265
2265 2264
2266 2267
2267 2266
2268 2269
2269 2268
226A 226B
226B 226A
226E 226F
226F 226E
2270 2271
2271 2270
2272 2273
2273 2272
2274 2275
2275 2274
2276 2277
2277 2276
2278 2279
2279 2278
227A 227B
227B 227A
227C 227D
227D 227C
227E 227F
227F 227E
2280 2281
2281 2280
2282 2283
2283 2282
2284 2285
2285 2284
2286 2287
2287 2286
2288 2289
2289 2288
228A 228B
228B 228A
228F 2290
2290 228F
2291 2292
2292 2291
2298 29B8
22A2 22A3
22A3 22A2
22A6 2ADE
22A8 2AE4
22A9 2AE3
22AB 2AE5
22B0 22B1
22B1 22B0
22B2 22B3
22B3 22B2
22B4 22B5
22B5 22B4
22B6 22B7
22B7 22B6
22C9 22CA
22CA 22C9
22CB 22CC
22CC 22CB
22CD 2243
22D0 22D1
22D1 22D0
22D6 22D7
22D7 22D6
22D8 22D9
22D9 22D8
22DA 22DB
22DB 22DA
22DC 22DD
22DD 22DC
22DE 22DF
22DF 22DE
22E0 22E1
22E1 22E0
22E2 22E3
22E3 22E2
22E4 22E5
22E5 22E4
22E6 22E7
22E7 22E6
22E8 22E9
22E9 22E8
22EA 22EB
22EB 22EA
22EC 22ED
22ED 22EC
22F0 22F1
22F1 22F0
22F2 22FA
22F3 22FB
22F4 22FC
22F6 22FD
22F7 22FE
22FA 22F2
22FB 22F3
22FC 22F4
22FD 22F6
22FE 22F7
2308 2309
2309 2308
230A 230B
230B 230A
2329 232A
232A 2329
2768 2769
2769 2768
276A 276B
276B 276A
276C 276D
276D 276C
276E 276F
276F 276E
2770 2771
2771 2770
2772 2773
2773 2772
2774 2775
2775 2774
27C3 27C4
27C4 27C3
27C5 27C6
27C6 27C5
27C8 27C9
27C9 27C8
27CB 27CD
27CD 27CB
27D5 27D6
27D6 27D5
27DD 27DE
27DE 27DD
27E2 27E3
27E3 27E2
27E4 27E5
27E5 27E4
27E6 27E7
27E7 27E6
27E8 27E9
27E9 27E8
27EA 27EB
27EB 27EA
27EC 27ED
27ED 27EC
27EE 27EF
27EF 27EE
2983 2984
2984 2983
2985 2986
2986 2985
2987 2988
2988 2987
2989 298A
298A 2989
298B 298C
298C 298B
298D 2990
298E 298F
298F 298E
2990 298D
2991 2992
2992 2991
2993 2994
2994 2993
2995 2996
2996 2995
2997 2998
2998 2997
29B8 2298
29C0 29C1
29C1 29C0
29C4 29C5
29C5 29C4
29CF 29D0
29D0 29CF
29D1 29D2
29D2 29D1
29D4 29D5
29D5 29D4
29D8 29D9
29D9 29D8
29DA 29DB
29DB 29DA
29F5 2215
29F8 29F9
29F9 29F8
29FC 29FD
29FD 29FC
2A2B 2A2C
2A2C 2A2B
2A2D 2A2E
2A2E 2A2D
2A34 2A35
2A35 2A34
2A3C 2A3D
2A3D 2A3C
2A64 2A65
2A65 2A64
2A79 2A7A
2A7A 2A79
2A7D 2A7E
2A7E 2A7D
2A7F 2A80
2A80 2A7F
2A81 2A82
2A82 2A81
2A83 2A84
2A84 2A83
2A8B 2A8C
2A8C 2A8B
2A91 2A92
2A92 2A91
2A93 2A94
2A94 2A93
2A95 2A96
2A96 2A95
2A97 2A98
2A98 2A97
2A99 2A9A
2A9A 2A99
2A9B 2A9C
2A9C 2A9B
2AA1 2AA2
2AA2 2AA1
2AA6 2AA7
2AA7 2AA6
2AA8 2AA9
2AA9 2AA8
2AAA 2AAB
2AAB 2AAA
2AAC 2AAD
2AAD 2AAC
2AAF 2AB0
2AB0 2AAF
2AB3 2AB4
2AB4 2AB3
2ABB 2ABC
2ABC 2ABB
2ABD 2ABE
2ABE 2ABD
2ABF 2AC0
2AC0 2ABF
2AC1 2AC2
2AC2 2AC1
2AC3 2AC4
2AC4 2AC3
2AC5 2AC6
2AC6 2AC5
2ACD 2ACE
2ACE 2ACD
2ACF 2AD0
2AD0 2ACF
2AD1 2AD2
2AD2 2AD1
2AD3 2AD4
2AD4 2AD3
2AD5 2AD6
2AD6 2AD5
2ADE 22A6
2AE3 22A9
2AE4 22A8
2AE5 22AB
2AEC 2AED
2AED 2AEC
2AF7 2AF8
2AF8 2AF7
2AF9 2AFA
2AFA 2AF9
2E02 2E03
2E03 2E02
2E04 2E05
2E05 2E04
2E09 2E0A
2E0A 2E09
2E0C 2E0D
2E0D 2E0C
2E1C 2E1D
2E1D 2E1C
2E20 2E21
2E21 2E20
2E22 2E23
2E23 2E22
2E24 2E25
2E25 2E24
2E26 2E27
2E27 2E26
2E28 2E29
2E29 2E28
3008 3009
3009 3008
300A 300B
300B 300A
300C 300D
300D 300C
300E 300F
300F 300E
3010 3011
3011 3010
3014 3015
3015 3014
3016 3017
3017 3016
3018 3019
3019 3018
301A 301B
301B 301A
FE59 FE5A
FE5A FE59
FE5B FE5C
FE5C FE5B
FE5D FE5E
FE5E FE5D
FE64 FE65
FE65 FE64
FF08 FF09
FF09 FF08
FF1C FF1E
FF1E FF1C
FF3B FF3D
FF3D FF3B
FF5B FF5D
FF5D FF5B
FF5F FF60
FF60 FF5F
FF62 FF63
FF63 FF62
END

140
vendor/LeOS/tools-leos/common/perl-base/unicore/To/Bpb.pl vendored
View File

@ -1,140 +0,0 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBpb'}{'format'} = 'x'; # non-negative hex whole number; a code point
$utf8::SwashInfo{'ToBpb'}{'missing'} = ''; # code point maps to the null string
return <<'END';
28 0029
29 0028
5B 005D
5D 005B
7B 007D
7D 007B
F3A 0F3B
F3B 0F3A
F3C 0F3D
F3D 0F3C
169B 169C
169C 169B
2045 2046
2046 2045
207D 207E
207E 207D
208D 208E
208E 208D
2308 2309
2309 2308
230A 230B
230B 230A
2329 232A
232A 2329
2768 2769
2769 2768
276A 276B
276B 276A
276C 276D
276D 276C
276E 276F
276F 276E
2770 2771
2771 2770
2772 2773
2773 2772
2774 2775
2775 2774
27C5 27C6
27C6 27C5
27E6 27E7
27E7 27E6
27E8 27E9
27E9 27E8
27EA 27EB
27EB 27EA
27EC 27ED
27ED 27EC
27EE 27EF
27EF 27EE
2983 2984
2984 2983
2985 2986
2986 2985
2987 2988
2988 2987
2989 298A
298A 2989
298B 298C
298C 298B
298D 2990
298E 298F
298F 298E
2990 298D
2991 2992
2992 2991
2993 2994
2994 2993
2995 2996
2996 2995
2997 2998
2998 2997
29D8 29D9
29D9 29D8
29DA 29DB
29DB 29DA
29FC 29FD
29FD 29FC
2E22 2E23
2E23 2E22
2E24 2E25
2E25 2E24
2E26 2E27
2E27 2E26
2E28 2E29
2E29 2E28
3008 3009
3009 3008
300A 300B
300B 300A
300C 300D
300D 300C
300E 300F
300F 300E
3010 3011
3011 3010
3014 3015
3015 3014
3016 3017
3017 3016
3018 3019
3019 3018
301A 301B
301B 301A
FE59 FE5A
FE5A FE59
FE5B FE5C
FE5C FE5B
FE5D FE5E
FE5E FE5D
FF08 FF09
FF09 FF08
FF3B FF3D
FF3D FF3B
FF5B FF5D
FF5D FF5B
FF5F FF60
FF60 FF5F
FF62 FF63
FF63 FF62
END

140
vendor/LeOS/tools-leos/common/perl-base/unicore/To/Bpt.pl vendored
View File

@ -1,140 +0,0 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBpt'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToBpt'}{'missing'} = 'n';
return <<'END';
28 o
29 c
5B o
5D c
7B o
7D c
F3A o
F3B c
F3C o
F3D c
169B o
169C c
2045 o
2046 c
207D o
207E c
208D o
208E c
2308 o
2309 c
230A o
230B c
2329 o
232A c
2768 o
2769 c
276A o
276B c
276C o
276D c
276E o
276F c
2770 o
2771 c
2772 o
2773 c
2774 o
2775 c
27C5 o
27C6 c
27E6 o
27E7 c
27E8 o
27E9 c
27EA o
27EB c
27EC o
27ED c
27EE o
27EF c
2983 o
2984 c
2985 o
2986 c
2987 o
2988 c
2989 o
298A c
298B o
298C c
298D o
298E c
298F o
2990 c
2991 o
2992 c
2993 o
2994 c
2995 o
2996 c
2997 o
2998 c
29D8 o
29D9 c
29DA o
29DB c
29FC o
29FD c
2E22 o
2E23 c
2E24 o
2E25 c
2E26 o
2E27 c
2E28 o
2E29 c
3008 o
3009 c
300A o
300B c
300C o
300D c
300E o
300F c
3010 o
3011 c
3014 o
3015 c
3016 o
3017 c
3018 o
3019 c
301A o
301B c
FE59 o
FE5A c
FE5B o
FE5C c
FE5D o
FE5E c
FF08 o
FF09 c
FF3B o
FF3D c
FF5B o
FF5D c
FF5F o
FF60 c
FF62 o
FF63 c
END

Some files were not shown because too many files have changed in this diff Show More