Merge branch 'master' of https://github.com/haytjes/arewefastyet
This commit is contained in:
Hannes Verschore
Коммит
2446ac144c
|
|
@ -25,6 +25,8 @@ benchmarks/asmjs-apps/zlib/minigzipsh
|
|||
|
||||
driver/awfy.config
|
||||
slave/awfy.config
|
||||
slave/results
|
||||
slave/profile
|
||||
**/*-results/
|
||||
|
||||
output/
|
||||
|
|
|
|||
94
README.md
94
README.md
|
|
@ -1,29 +1,50 @@
|
|||
AreWeFastYet
|
||||
============
|
||||
|
||||
AreWeFastYet is a set of tools used for benchmarking the major browser's
|
||||
JavaScript virtual machines against each other, as well as reporting the
|
||||
results on a website as insightful graphs showing the evolution of performance
|
||||
over time.
|
||||
|
||||
A public instance is hosted by Mozilla and running at
|
||||
[https://arewefastyet.com](https://arewefastyet.com).
|
||||
|
||||
Components
|
||||
==========
|
||||
|
||||
Slave:
|
||||
|
||||
1. Builder: A python driver (build.py) that can create shell builds of spidermonkey/jsc/v8.
|
||||
2. Downloader: A python driver (download.py) that can download browser builds of Firefox.
|
||||
3. Executor: (execute.py) is a python script that executes one or multiple benchmarks on one or more builds.
|
||||
1. Builder: A python driver (build.py) that can create shell builds of
|
||||
spidermonkey/jsc/v8.
|
||||
2. Downloader: A python driver (download.py) that can download browser builds
|
||||
of Firefox.
|
||||
3. Executor: (execute.py) is a python script that executes one or multiple
|
||||
benchmarks on one or more builds.
|
||||
|
||||
Site:
|
||||
|
||||
1. Database: MySQL database that stores statistics.
|
||||
2. Collector: Hidden PHP script on the webserver, where stats get sent. (UPDATE.php in below diagram)
|
||||
3. Processor: Python aggregator that builds JSON data from the DB. (update.py in below diagram)
|
||||
2. Collector: Hidden PHP script on the webserver, where stats get sent.
|
||||
(UPDATE.php in below diagram)
|
||||
3. Processor: Python aggregator that builds JSON data from the DB. (update.py
|
||||
in below diagram)
|
||||
4. Website: Static HTML as the frontpage, that queries JSON via XHR.
|
||||
5. Command center: Sends commands to the slaves on what to execute. (In construction.)
|
||||
5. Command center: Sends commands to the slaves on what to execute. (In
|
||||
construction.)
|
||||
|
||||
Components (2) and (4) must be on the same webserver, otherwise timestamps might not be computed correctly.
|
||||
Components (2) and (4) must be on the same webserver, otherwise timestamps
|
||||
might not be computed correctly.
|
||||
|
||||
Keep in mind, most of this documentation is for posterity. AWFY was never intended to be a drag-and-drop all-in-one released product, so the procedures and scripts may be pretty rough.
|
||||
Keep in mind, most of this documentation is for posterity. AWFY was never
|
||||
intended to be a drag-and-drop all-in-one released product, so the procedures
|
||||
and scripts may be pretty rough.
|
||||
|
||||
System Diagram
|
||||
==============
|
||||
<!--
|
||||
Image source at https://docs.google.com/drawings/d/1TlzFOMz4oxKYSD_hHqe-fL2wpAA5WwhEq62KJp0TytI/edit?usp=sharing
|
||||
To edit it, 'make a copy' (from file menu) and edit that.
|
||||
<!--
|
||||
Image source at
|
||||
https://docs.google.com/drawings/d/1TlzFOMz4oxKYSD_hHqe-fL2wpAA5WwhEq62KJp0TytI/edit?usp=sharing
|
||||
To edit it, 'make a copy' (from file menu) and edit that.
|
||||
-->
|
||||
|
||||
|
||||
|
|
@ -57,17 +78,24 @@ Installation
|
|||
|
||||
Database
|
||||
--------
|
||||
Put `/server/awfy-server.config` in `/etc`, and edit it to point at your database. Afterwards just run 'php migrate.php' to create the tables and run the migrations.
|
||||
(Note: sometimes the database layout changes a bit. After pulling it is recommanded to run php migrate.php again. That will incremental adjust the database to the new layout,
|
||||
transforming existing entries.)
|
||||
Put `/server/awfy-server.config` in `/etc`, and edit it to point at your
|
||||
database. Afterwards just run `php migrate.php` to create the tables and run
|
||||
the migrations. (Note: sometimes the database layout changes a bit. After
|
||||
pulling it is recommanded to run `php migrate.php` again. That will incremental
|
||||
adjust the database to the new layout, transforming existing entries.)
|
||||
|
||||
Data Collector
|
||||
--------------
|
||||
Drop `website/UPDATE.PHP` and `website/internals.php` somewhere, and rename `UPDATE.PHP` to something secret. Make sure you don't have directory listings enabled.
|
||||
Drop `website/UPDATE.PHP` and `website/internals.php` somewhere, and rename
|
||||
`UPDATE.PHP` to something secret. Make sure you don't have directory listings
|
||||
enabled.
|
||||
|
||||
Slave DNS Config
|
||||
----------------
|
||||
Before running the benchmarks, add these lines to your `/etc/hosts` file and flush DNS cache. These host addresses are used by `benchmarks_remote.py`. This configuration is needed for all the slaves that use the remote or local benchmarks. Only the shell benchmarks don't need it.
|
||||
Before running the benchmarks, add these lines to your `/etc/hosts` file and
|
||||
flush DNS cache. These host addresses are used by `benchmarks_remote.py`. This
|
||||
configuration is needed for all the slaves that use the remote or local
|
||||
benchmarks. Only the shell benchmarks don't need it.
|
||||
|
||||
```
|
||||
# Subdomains for AWFY
|
||||
|
|
@ -87,23 +115,39 @@ Benchmark Computers
|
|||
-------------------
|
||||
|
||||
In development...
|
||||
|
||||
|
||||
Data Processor
|
||||
--------------
|
||||
Put `awfy-server.config` in `/etc`, and edit it to point at your database and website/data folder. Then put `update.py` in a cronjob. It will dump files where appropriate. AWFY.com does this every 15min. It is not safe to run two instance at once. A sample wrapper script is provided as `run-update.sh`.
|
||||
Put `awfy-server.config` in `/etc`, and edit it to point at your database and
|
||||
website/data folder. Then put `update.py` in a cronjob. It will dump files
|
||||
where appropriate. AWFY.com does this every 15min. It is not safe to run two
|
||||
instance at once. A sample wrapper script is provided as `run-update.sh`.
|
||||
|
||||
update.py generates various JSON files:
|
||||
|
||||
1. "raw" and "metadata" files cache database queries from run to run, so we don't have to make expensive database queries.
|
||||
1. "raw" and "metadata" files cache database queries from run to run, so we
|
||||
don't have to make expensive database queries.
|
||||
2. "aggregate" files are used for the front page.
|
||||
3. "condensed" files are used for one level of zooming, so users don't have to download the raw data set right away.
|
||||
|
||||
The metadata and raw JSON files are updated as needed. The aggregate and condensed files are always re-generated from the raw data.
|
||||
3. "condensed" files are used for one level of zooming, so users don't have to
|
||||
download the raw data set right away.
|
||||
|
||||
There is also a `monitor.py` script provided in the server folder. You can run this regularly to send e-mails for benchmarking machines that haven't sent results in a certain amount of time (this time is specified in awfy-server.config). It will send e-mail through the local SMTP server, using the "contact" field for each machine in the database. This field should be a comma-delimited list of e-mail addresses (i.e. "egg@yam.com,bob@egg.com").
|
||||
The metadata and raw JSON files are updated as needed. The aggregate and
|
||||
condensed files are always regenerated from the raw data.
|
||||
|
||||
There is also a `monitor.py` script provided in the server folder. You can run
|
||||
this regularly to send e-mails for benchmarking machines that haven't sent
|
||||
results in a certain amount of time (this time is specified in
|
||||
`awfy-server.config`). It will send e-mail through the local SMTP server, using
|
||||
the "contact" field for each machine in the database. This field should be a
|
||||
comma-delimited list of e-mail addresses (i.e. "egg@yam.com,bob@egg.com").
|
||||
|
||||
Website
|
||||
-------
|
||||
Put the files somewhere. Currently php is needed for data.php, which pulls the data from the correct location. You just need to update config file (`/etc/awfy-server.config`) to refer the 'data' folder that contains the json/js files dumped by update.py.
|
||||
Put the files somewhere. Currently php is needed for `data.php`, which pulls the
|
||||
data from the correct location. You just need to update config file
|
||||
(`/etc/awfy-server.config`) to refer the 'data' folder that contains the
|
||||
json/js files dumped by update.py.
|
||||
|
||||
Don't forget to replace the default machine number in website/awfy.js, which is the one that will show up in the first place. Note that AWFY's flot is slightly modified, so it might not work to just replace it with upstream flot.
|
||||
Don't forget to replace the default machine number in website/awfy.js, which is
|
||||
the one that will show up in the first place. Note that AWFY's flot is slightly
|
||||
modified, so it might not work to just replace it with upstream flot.
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
#!/bin/bash
|
||||
|
||||
echo -e "box2d-loadtime - \c"
|
||||
$1 run.js -- box2d.js 1
|
||||
echo -e "box2d-throughput - \c"
|
||||
$1 run.js -- box2d.js 3
|
||||
echo -e "bullet-loadtime - \c"
|
||||
$1 run.js -- bullet.js 1
|
||||
echo -e "bullet-throughput - \c"
|
||||
$1 run.js -- bullet.js 3
|
||||
echo -e "lua_binarytrees-loadtime - \c"
|
||||
$1 run.js -- lua_binarytrees.js 1
|
||||
echo -e "lua_binarytrees-throughput - \c"
|
||||
$1 run.js -- lua_binarytrees.js 3
|
||||
echo -e "box2d-loadtime - \c"
|
||||
$1 run.js -- zlib.js 1
|
||||
echo -e "box2d-throughput - \c"
|
||||
$1 run.js -- zlib.js 3
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!/bin/bash
|
||||
|
||||
echo -e "copy - \c"
|
||||
$1 ubench.js -- copy.js 4
|
||||
echo -e "corrections - \c"
|
||||
$1 ubench.js -- corrections.js 4
|
||||
echo -e "fannkuch - \c"
|
||||
$1 ubench.js -- fannkuch.js 4
|
||||
echo -e "fasta - \c"
|
||||
$1 ubench.js -- fasta.js 4
|
||||
echo -e "life - \c"
|
||||
$1 ubench.js -- life.js 4
|
||||
echo -e "memops - \c"
|
||||
$1 ubench.js -- memops.js 4
|
||||
echo -e "primes- \c"
|
||||
$1 ubench.js -- primes.js 4
|
||||
echo -e "skinning - \c"
|
||||
$1 ubench.js -- skinning.js 4
|
||||
echo -e "mandelbrot-native - \c"
|
||||
$1 ubench.js -- mandelbrot-native.js 4
|
||||
echo -e "mandelbrot-polyfill - \c"
|
||||
$1 ubench.js -- mandelbrot-polyfill.js 4
|
||||
echo -e "fbirds-native - \c"
|
||||
$1 ubench.js -- fbirds-native.js 4
|
||||
echo -e "fbirds-polyfill - \c"
|
||||
$1 ubench.js -- fbirds-polyfill.js 4
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
|
||||
for (var i = 0; i < 20; i++) {
|
||||
var x = JSON.stringify(tinderbox_data);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
0.7
|
||||
0.8
|
||||
|
|
|
|||
|
|
@ -40,3 +40,4 @@ misc-basic-hoist-bounds-check
|
|||
misc-apply-array
|
||||
misc-apply-array-headroom
|
||||
misc-map-iterator
|
||||
misc-react-shell
|
||||
|
|
|
|||
Различия файлов скрыты, потому что одна или несколько строк слишком длинны
|
|
@ -0,0 +1,3 @@
|
|||
var ReactDOM = React.__SECRET_DOM_DO_NOT_USE_OR_YOU_WILL_BE_FIRED;
|
||||
var ReactDOMServer = React.__SECRET_DOM_SERVER_DO_NOT_USE_OR_YOU_WILL_BE_FIRED;
|
||||
ReactDOMServer.renderToString(React.createElement(Benchmark));
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
(lp0
|
||||
I200
|
||||
a(lp1
|
||||
(S'content-length'
|
||||
p2
|
||||
S'1006'
|
||||
p3
|
||||
tp4
|
||||
a(S'accept-ranges'
|
||||
p5
|
||||
S'bytes'
|
||||
p6
|
||||
tp7
|
||||
a(S'server'
|
||||
p8
|
||||
S'Apache/2.2'
|
||||
p9
|
||||
tp10
|
||||
a(S'last-modified'
|
||||
p11
|
||||
S'Tue, 08 Oct 2013 22:38:52 GMT'
|
||||
p12
|
||||
tp13
|
||||
a(S'connection'
|
||||
p14
|
||||
S'close'
|
||||
p15
|
||||
tp16
|
||||
a(S'etag'
|
||||
p17
|
||||
S'"3200bf-3ee-4e8426ee472db"'
|
||||
p18
|
||||
tp19
|
||||
a(S'date'
|
||||
p20
|
||||
S'Thu, 26 Nov 2015 21:07:24 GMT'
|
||||
p21
|
||||
tp22
|
||||
a(S'content-type'
|
||||
p23
|
||||
S'text/css'
|
||||
p24
|
||||
tp25
|
||||
aaS'\nbody { font-family: sans-serif;\n margin: 20px; \n background-color: #D9D5A1; \n color: #1B0636 }\n\nh2 { background-color: #4E8AB9; \n margin: -20px -20px 0px -20px; \n padding: 30px 20px 30px 20px; \n color: yellow;\n border-bottom: 2px solid #360D6B;\n zoom: 1.0 /* I CAN HAS LAYOUT? (ie hack) */ }\n\ndt { font-weight: bold }\n\ndd { margin-bottom: 1em; margin-top: 0.5em }\n\n:link { color: #1363A1 }\n:visited { color: #5113A1 }\n\n#testframe { margin-top: 20px;\n width: 80%;\n height: 500px;\n border: 2px solid #360D6B }\n\n#logo { float: left;\n position: relative; \n bottom: 0.33em;\n padding-right: 20px;\n margin-bottom: -40px; \n font-size: 3em }\n\n#frameparent { visibility: hidden; }\n\n#countdown { margin-top: 20px;\n padding-top: 150px;\n width: 80%;\n height: 350px;\n border: 2px solid #360D6B;\n font-size: 128px; \n text-align: center; }\n'
|
||||
p26
|
||||
a.
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
(lp0
|
||||
I200
|
||||
a(lp1
|
||||
(S'content-length'
|
||||
p2
|
||||
S'613'
|
||||
p3
|
||||
tp4
|
||||
a(S'accept-ranges'
|
||||
p5
|
||||
S'bytes'
|
||||
p6
|
||||
tp7
|
||||
a(S'server'
|
||||
p8
|
||||
S'Apache/2.2'
|
||||
p9
|
||||
tp10
|
||||
a(S'last-modified'
|
||||
p11
|
||||
S'Fri, 27 Sep 2013 01:45:05 GMT'
|
||||
p12
|
||||
tp13
|
||||
a(S'connection'
|
||||
p14
|
||||
S'close'
|
||||
p15
|
||||
tp16
|
||||
a(S'etag'
|
||||
p17
|
||||
S'"3200d1-265-4e753a2b85c3d"'
|
||||
p18
|
||||
tp19
|
||||
a(S'date'
|
||||
p20
|
||||
S'Thu, 26 Nov 2015 21:07:24 GMT'
|
||||
p21
|
||||
tp22
|
||||
a(S'content-type'
|
||||
p23
|
||||
S'text/javascript'
|
||||
p24
|
||||
tp25
|
||||
aaS'var tests = [ "3d-cube", "3d-morph", "3d-raytrace", "access-binary-trees", "access-fannkuch", "access-nbody", "access-nsieve", "bitops-3bit-bits-in-byte", "bitops-bits-in-byte", "bitops-bitwise-and", "bitops-nsieve-bits", "controlflow-recursive", "crypto-aes", "crypto-md5", "crypto-sha1", "date-format-tofte", "date-format-xparb", "math-cordic", "math-partial-sums", "math-spectral-norm", "regexp-dna", "string-base64", "string-fasta", "string-tagcloud", "string-unpack-code", "string-validate-input" ];\nvar categories = [ "3d", "access", "bitops", "controlflow", "crypto", "date", "math", "regexp", "string" ];\n'
|
||||
p26
|
||||
a.
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
(lp0
|
||||
I200
|
||||
a(lp1
|
||||
(S'content-length'
|
||||
p2
|
||||
S'4226'
|
||||
p3
|
||||
tp4
|
||||
a(S'x-powered-by'
|
||||
p5
|
||||
S'PHP/5.3.3'
|
||||
p6
|
||||
tp7
|
||||
a(S'server'
|
||||
p8
|
||||
S'Apache/2.2'
|
||||
p9
|
||||
tp10
|
||||
a(S'connection'
|
||||
p11
|
||||
S'close'
|
||||
p12
|
||||
tp13
|
||||
a(S'date'
|
||||
p14
|
||||
S'Thu, 26 Nov 2015 21:07:24 GMT'
|
||||
p15
|
||||
tp16
|
||||
a(S'content-type'
|
||||
p17
|
||||
S'text/html; charset=UTF-8'
|
||||
p18
|
||||
tp19
|
||||
aaS'<!DOCTYPE html>\n<html>\n<head>\n\n<meta charset=utf8>\n\n<!--\n Copyright (C) 2007 Apple Inc. All rights reserved.\n\n Redistribution and use in source and binary forms, with or without\n modification, are permitted provided that the following conditions\n are met:\n 1. Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n 2. Redistributions in binary form must reproduce the above copyright\n notice, this list of conditions and the following disclaimer in the\n documentation and/or other materials provided with the distribution.\n\n THIS SOFTWARE IS PROVIDED BY APPLE INC. ``AS IS\'\' AND ANY\n EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\n IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR\n PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL APPLE INC. OR\n CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,\n EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,\n PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR\n PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY\n OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\n OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \n-->\n\n<title>SunSpider 1.0.2 JavaScript Benchmark (sunspider-1.0.2 test suite - In Progress...)</title>\n<link rel="stylesheet" href="../sunspider.css">\n</head>\n\n<body onload="start()">\n\n<h2><span id="logo">☀</span>SunSpider JavaScript Benchmark <small>(In Progress...)</small></h2>\n<h3>Content Version: sunspider-1.0.2</h3>\n\n<script src="sunspider-test-prefix.js"></script>\n<script src="sunspider-test-contents.js"></script>\n<script>\nvar testIndex = -1;\nvar currentRepeat = -1;\nvar repeatCount = 10;\nvar warmupMS = 8;\n\nvar output = [];\noutput.length = repeatCount;\nfor (var i = 0; i < output.length; i++) {\n output[i] = {};\n}\n\nfunction warmup()\n{\n for (var start = new Date; new Date - start < warmupMS; ) {\n for (var i = 0; i < 100; ++i) {\n if (Math.atan(Math.acos(Math.asin(Math.random()))) > 4) // Always false.\n return;\n }\n }\n}\n\nfunction start() \n{\n window.setTimeout(next, 128);\n}\n\nfunction next()\n{\n document.getElementById("frameparent").innerHTML = "";\n document.getElementById("frameparent").innerHTML = "<iframe id=\'testframe\'>";\n var testFrame = document.getElementById("testframe");\n if (++testIndex < tests.length) {\n // Warm up the CPU a little bit, in case power management clocked it down\n // or put it to sleep. We\'re trying to strike a balance here: do enough\n // work so that all browsers see the CPU at an equal clock rate, but\n // not so much work that we hide performance problems caused by overly\n // aggressive power management.\n warmup();\n\n testFrame.contentDocument.open();\n testFrame.contentDocument.write(testContents[testIndex]);\n testFrame.contentDocument.close();\n\n window.setTimeout(next, 0);\n } else if (++currentRepeat < repeatCount) { \n document.getElementById("countdown").innerHTML = repeatCount - currentRepeat;\n testIndex = -1;\n\n window.setTimeout(next, 128);\n } else {\n finish();\n }\n}\n\nfunction recordResult(time)\n{\n if (currentRepeat >= 0) // negative repeats are warmups\n output[currentRepeat][tests[testIndex]] = time;\n}\n\nfunction finish()\n{\n var outputString = "{";\n outputString += \'"v": "sunspider-1.0.2", \';\n for (var test in output[0]) {\n outputString += \'"\' + test + \'":[\';\n for (var i = 0; i < output.length; i++) {\n var time = output[i][test];\n if (time != time)\n time = "\\"NaN\\"";\n outputString += time + ",";\n }\n outputString = outputString.substring(0, outputString.length - 1);\n outputString += "],";\n }\n outputString = outputString.substring(0, outputString.length - 1);\n outputString += "}";\n\n location = "results.html?" + encodeURI(outputString);\n}\n\n</script>\n\n<h3 id="countdown">warmup</h3>\n<div id="frameparent"></div>\n\n</body>\n</html>\n'
|
||||
p20
|
||||
a.
|
||||
Различия файлов скрыты, потому что одна или несколько строк слишком длинны
|
|
@ -0,0 +1,46 @@
|
|||
(lp0
|
||||
I200
|
||||
a(lp1
|
||||
(S'content-length'
|
||||
p2
|
||||
S'894'
|
||||
p3
|
||||
tp4
|
||||
a(S'accept-ranges'
|
||||
p5
|
||||
S'bytes'
|
||||
p6
|
||||
tp7
|
||||
a(S'server'
|
||||
p8
|
||||
S'Apache/2.2'
|
||||
p9
|
||||
tp10
|
||||
a(S'last-modified'
|
||||
p11
|
||||
S'Tue, 18 Nov 2008 20:23:58 GMT'
|
||||
p12
|
||||
tp13
|
||||
a(S'connection'
|
||||
p14
|
||||
S'close'
|
||||
p15
|
||||
tp16
|
||||
a(S'etag'
|
||||
p17
|
||||
S'"1609da-37e-45bfc79ab5380"'
|
||||
p18
|
||||
tp19
|
||||
a(S'date'
|
||||
p20
|
||||
S'Thu, 26 Nov 2015 21:07:24 GMT'
|
||||
p21
|
||||
tp22
|
||||
a(S'content-type'
|
||||
p23
|
||||
S'image/vnd.microsoft.icon'
|
||||
p24
|
||||
tp25
|
||||
aaS'\x00\x00\x01\x00\x01\x00\x10\x10\x00\x00\x01\x00\x18\x00h\x03\x00\x00\x16\x00\x00\x00(\x00\x00\x00\x10\x00\x00\x00 \x00\x00\x00\x01\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x0b\x00\x00\x13\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00UNk\x8d.9\x8e/;\x924;\x945<\x969?\xaefk\x99;A\xc4\x8e\x90\xc6\x8f\x94\xc0vykg\xb4\x00\x1e\xf8\x08\x1a\x86\x9935\xa00AF|\xa0\x88-3\x99HM\x95@G\x96?F\x98@G\x95:A\x957A\xb3pw\xff\xff\xff\xb0fu\xa7?B]C\x95\x00\x19\xeeI/`\xa7@IA\xa5\xd0`3F\xaafl\xa6ck\x9aKS\x9bMT\x9cMU\x9cHQ\xb9\x81\x87\xe6\xd2\xd4\x9aBO\xa0IZ\xacMOcK\x9b\x00\x1c\xd4\x8fLU+\x96\xc36f\x8c\x98MW\xads}\xa2^g\xa5`i\xa5`l\xa0Zi\xb8\x84\x8e\xc6\x99\x9c\xa5[e\xa7`l\xa6_p\xb4cedQ\xa51:\xae\x00e\x940\x9e\xcfOF_\xb3u|\xaey\x83\xadv\x81\xaew\x81\xa4ds\xadu\x80\xacoy\xb0s}\xb1w\x83\xb1v\x84\xb1v\x84\xc4\x83\x84wj\xb2O\x9c\xbe\x04f\x93*\x90\xc0jQd\xc3\x90\x98\xbd\x93\x9b\xb6\x87\x90\xadv\x81\xcb\xa8\xb0\xcf\xad\xb4\xb1}\x8c\xbd\x8f\x9b\xbd\x8e\x9a\xbc\x8d\x99\xca\xa2\xad\xce\x9e\xa1\xe9\xf8\xfe.}\xa1\x0bm\x9a+\x8d\xbde[q\xc2\x94\x99\xca\xa2\xa7\xce\xad\xb2\xe2\xd0\xd5\xbf\x98\xa1\xbe\x96\xa2\xc6\xa0\xa8\xc9\xa4\xab\xcf\xa8\xb3\xc4\x96\xa0\x80Yo\x96\xcc\xe5\xef\xf9\xfe)u\x99\x07i\x930\x98\xc5Gj\x8a\x8du\x81\xbe\x93\x99\xc8\x9c\xa1\xca\xa1\xa7\xd0\xa8\xae\xce\xa7\xab\xc2\x96\x9b\x9bv\x83af\x83F\x93\xb84\x90\xb3\xb3\xdb\xed\xf2\xfd\xff@\x89\xaa\x00U})\x8c\xb69\x8f\xb9S\x84\xa6v\x8a\xa4pj\x82uk\x84jq\x88Ww\x96@\x89\xb1(\x8c\xb6\x05l\x9ak\xa7\xb3=\x94\xb4\xaa\xd5\xe9\xfb\xff\xff\x83\xb9\xd2\x07a\x89\x00Z\x83\x1cy\xa0+\x8a\xb45\x90\xb94\x90\xb8(\x8c\xb7\x17}\xa7\x04j\x96\x11u\xa1T\xaa\xd0v\xb2\xbel\xa7\xb4G\x96\xb1\x80\xbc\xd5\xec\xf8\xfe\xe1\xf4\xfe~\xba\xd4-\x82\xa8\rj\x95\x07e\x90\x0ck\x95\x1fx\xa0G\x95\xb9\x8a\xc3\xdc\xc3\xe3\xf4\xb4\xda\xed\x83\xbe\xccp\xaa\xb7v\xb3\xbf^\xa6\xb9Y\xa5\xc0\x9e\xcb\xdd\xfb\xfe\xff\xff\xff\xff\xef\xfb\xff\xd5\xed\xf8\xd6\xee\xf9\xe2\xf4\xfb\xe3\xf3\xfe\xc2\xe0\xf1\x80\xc2\xd9T\xb6\xc2\x93\xce\xdb\x89\xc4\xd2\x84\xc0\xd0\x92\xd4\xe6\x84\xc6\xd6K\x94\xabF\x9b\xc2\x90\xc6\xe0\x8a\xc0\xd6\x94\xcb\xe1\x92\xcb\xe0~\xc0\xdae\xb4\xbfd\xc4\xc3v\xd6\xc3\x8e\xe9\xcb\x86\xda\xc4\x86\xd4\xc6\x82\xca\xc4\x8c\xd1\xd4\x80\xc3\xceO\x9c\xb7i\xb8\xd4<\x94\xb8A\x96\xb4\x87\xce\xdf\x84\xcc\xdf{\xc0\xcb{\xd2\xb6\x90\xed\xcf\x8f\xeb\xcf\x8d\xe8\xce\x8a\xe9\xce\x8a\xe9\xcc\x89\xe7\xca\x87\xe3\xc6\x81\xdb\xc3A\x99\xa5m\xb1\xa7^\xa1\xa6Q\xa5\xb9\x92\xd2\xdc\x94\xd2\xe3\x80\xc3\xc2\x83\xe0\xc3\x8a\xe8\xce\x8a\xe8\xcc\x8a\xe8\xcc\x89\xe7\xcc\x89\xe7\xcc\x89\xe7\xcc\x8a\xe8\xce\x8d\xeb\xcev\xd6\xc5Q\xb0\xadW\xb7\xb2\x81\xdd\xc5\x83\xdc\xc4\x84\xd6\xc5\x82\xd7\xc3\x88\xe7\xcb\x89\xe7\xcc\x89\xe7\xcc\x89\xe7\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00'
|
||||
p26
|
||||
a.
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
<?php
|
||||
|
||||
|
||||
$migrate = function() {
|
||||
mysql_query("ALTER TABLE `control_task_queue` ADD `output` LONGTEXT NOT NULL AFTER `finish`;") or die(mysql_error());
|
||||
};
|
||||
|
||||
$rollback = function() {
|
||||
mysql_query("ALTER TABLE `control_task_queue` DROP `output`;") or die(mysql_error());
|
||||
};
|
||||
|
|
@ -0,0 +1,778 @@
|
|||
#!/usr/bin/python
|
||||
|
||||
# Copyright 2014 Google Inc. All rights reserved.
|
||||
#
|
||||
# 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.
|
||||
|
||||
"""Sync files from/to an Android device."""
|
||||
|
||||
from __future__ import unicode_literals
|
||||
import argparse
|
||||
import glob
|
||||
import locale
|
||||
import os
|
||||
import re
|
||||
import stat
|
||||
import subprocess
|
||||
import sys
|
||||
import time
|
||||
|
||||
|
||||
def _sprintf(s, *args):
|
||||
# To be able to use string formatting, we first have to covert to
|
||||
# unicode strings; however, we must do so in a way that preserves all
|
||||
# bytes, and convert back at the end. An encoding that maps all byte
|
||||
# values to different Unicode codepoints is cp437.
|
||||
return (s.decode('cp437') % tuple([
|
||||
(x.decode('cp437') if type(x) == bytes else x) for x in args
|
||||
])).encode('cp437')
|
||||
|
||||
|
||||
def _print(s, *args):
|
||||
"""Writes a binary string to stdout.
|
||||
|
||||
Args:
|
||||
s: The binary format string to write.
|
||||
args: The args for the format string.
|
||||
"""
|
||||
if hasattr(sys.stdout, 'buffer'):
|
||||
# Python 3.
|
||||
sys.stdout.buffer.write(_sprintf(s, *args) + b'\n')
|
||||
sys.stdout.buffer.flush()
|
||||
else:
|
||||
# Python 2.
|
||||
sys.stdout.write(_sprintf(s, *args) + b'\n')
|
||||
|
||||
|
||||
class AdbFileSystem(object):
|
||||
"""Mimics os's file interface but uses the adb utility."""
|
||||
|
||||
def __init__(self, adb):
|
||||
self.stat_cache = {}
|
||||
self.adb = adb
|
||||
|
||||
# Regarding parsing stat results, we only care for the following fields:
|
||||
# - st_size
|
||||
# - st_mtime
|
||||
# - st_mode (but only about S_ISDIR and S_ISREG properties)
|
||||
# Therefore, we only capture parts of 'ls -l' output that we actually use.
|
||||
# The other fields will be filled with dummy values.
|
||||
LS_TO_STAT_RE = re.compile(br'''^
|
||||
(?:
|
||||
(?P<S_IFREG> -) |
|
||||
(?P<S_IFBLK> b) |
|
||||
(?P<S_IFCHR> c) |
|
||||
(?P<S_IFDIR> d) |
|
||||
(?P<S_IFLNK> l) |
|
||||
(?P<S_IFIFO> p) |
|
||||
(?P<S_IFSOCK> s))
|
||||
[-r][-w][-xsS]
|
||||
[-r][-w][-xsS]
|
||||
[-r][-w][-xtT] # Mode string.
|
||||
[ ]+
|
||||
(?:
|
||||
[0-9]+ # number of hard links
|
||||
[ ]+
|
||||
)?
|
||||
[^ ]+ # User name/ID.
|
||||
[ ]+
|
||||
[^ ]+ # Group name/ID.
|
||||
[ ]+
|
||||
(?(S_IFBLK) [^ ]+[ ]+[^ ]+[ ]+) # Device numbers.
|
||||
(?(S_IFCHR) [^ ]+[ ]+[^ ]+[ ]+) # Device numbers.
|
||||
(?(S_IFDIR) [0-9]+ [ ]+)? # directory Size.
|
||||
(?(S_IFREG)
|
||||
(?P<st_size> [0-9]+) # Size.
|
||||
[ ]+)
|
||||
(?P<st_mtime>
|
||||
[0-9]{4}-[0-9]{2}-[0-9]{2} # Date.
|
||||
[ ]
|
||||
[0-9]{2}:[0-9]{2}) # Time.
|
||||
[ ]
|
||||
# Don't capture filename for symlinks (ambiguous).
|
||||
(?(S_IFLNK) .* | (?P<filename> .*))
|
||||
$''', re.DOTALL | re.VERBOSE)
|
||||
def LsToStat(self, line):
|
||||
"""Convert a line from 'ls -l' output to a stat result.
|
||||
|
||||
Args:
|
||||
line: Output line of 'ls -l' on Android.
|
||||
|
||||
Returns:
|
||||
os.stat_result for the line.
|
||||
|
||||
Raises:
|
||||
OSError: if the given string is not a 'ls -l' output line (but maybe an
|
||||
error message instead).
|
||||
"""
|
||||
|
||||
match = self.LS_TO_STAT_RE.match(line)
|
||||
if match is None:
|
||||
_print(b'Warning: could not parse %r.', line)
|
||||
raise OSError('Unparseable ls -al result.')
|
||||
groups = match.groupdict()
|
||||
|
||||
# Get the values we're interested in.
|
||||
st_mode = ( # 0755
|
||||
stat.S_IRWXU | stat.S_IRGRP | stat.S_IXGRP | stat.S_IROTH | stat.S_IXOTH)
|
||||
if groups['S_IFREG']: st_mode |= stat.S_IFREG
|
||||
if groups['S_IFBLK']: st_mode |= stat.S_IFBLK
|
||||
if groups['S_IFCHR']: st_mode |= stat.S_IFCHR
|
||||
if groups['S_IFDIR']: st_mode |= stat.S_IFDIR
|
||||
if groups['S_IFIFO']: st_mode |= stat.S_IFIFO
|
||||
if groups['S_IFLNK']: st_mode |= stat.S_IFLNK
|
||||
if groups['S_IFSOCK']: st_mode |= stat.S_IFSOCK
|
||||
st_size = groups['st_size']
|
||||
if st_size is not None:
|
||||
st_size = int(st_size)
|
||||
st_mtime = time.mktime(time.strptime(match.group('st_mtime').decode('utf-8'),
|
||||
'%Y-%m-%d %H:%M'))
|
||||
|
||||
# Fill the rest with dummy values.
|
||||
st_ino = 1
|
||||
st_rdev = 0
|
||||
st_nlink = 1
|
||||
st_uid = -2 # Nobody.
|
||||
st_gid = -2 # Nobody.
|
||||
st_atime = st_ctime = st_mtime
|
||||
|
||||
stbuf = os.stat_result((st_mode, st_ino, st_rdev, st_nlink, st_uid, st_gid,
|
||||
st_size, st_atime, st_mtime, st_ctime))
|
||||
filename = groups['filename']
|
||||
return stbuf, filename
|
||||
|
||||
def Stdout(self, *popen_args):
|
||||
"""Closes the process's stdout when done.
|
||||
|
||||
Usage:
|
||||
with Stdout(...) as stdout:
|
||||
DoSomething(stdout)
|
||||
|
||||
Args:
|
||||
popen_args: Arguments for subprocess.Popen; stdout=PIPE is implicitly
|
||||
added.
|
||||
|
||||
Returns:
|
||||
An object for use by 'with'.
|
||||
"""
|
||||
|
||||
class Stdout(object):
|
||||
def __init__(self, popen):
|
||||
self.popen = popen
|
||||
|
||||
def __enter__(self):
|
||||
return self.popen.stdout
|
||||
|
||||
def __exit__(self, exc_type, exc_value, traceback):
|
||||
self.popen.stdout.close()
|
||||
if self.popen.wait() != 0:
|
||||
raise OSError('Subprocess exited with nonzero status.')
|
||||
return False
|
||||
|
||||
return Stdout(subprocess.Popen(*popen_args, stdout=subprocess.PIPE))
|
||||
|
||||
def QuoteArgument(self, arg):
|
||||
# Quotes an argument for use by adb shell.
|
||||
# Usually, arguments in 'adb shell' use are put in double quotes by adb,
|
||||
# but not in any way escaped.
|
||||
arg = arg.replace(b'\\', b'\\\\')
|
||||
arg = arg.replace(b'"', b'\\"')
|
||||
arg = arg.replace(b'$', b'\\$')
|
||||
arg = arg.replace(b'`', b'\\`')
|
||||
arg = b'"' + arg + b'"'
|
||||
return arg
|
||||
|
||||
def IsWorking(self):
|
||||
"""Tests the adb connection."""
|
||||
# This string should contain all possible evil, but no percent signs.
|
||||
# Note this code uses 'date' and not 'echo', as date just calls strftime
|
||||
# while echo does its own backslash escape handling additionally to the
|
||||
# shell's. Too bad printf "%s\n" is not available.
|
||||
test_strings = [
|
||||
b'(',
|
||||
b'(; #`ls`$PATH\'"(\\\\\\\\){};!\xc0\xaf\xff\xc2\xbf'
|
||||
]
|
||||
for test_string in test_strings:
|
||||
good = False
|
||||
with self.Stdout(self.adb + [b'shell', _sprintf(b'date +%s',
|
||||
self.QuoteArgument(test_string))]) as stdout:
|
||||
for line in stdout:
|
||||
line = line.rstrip(b'\r\n')
|
||||
if line == test_string:
|
||||
good = True
|
||||
if not good:
|
||||
return False
|
||||
return True
|
||||
|
||||
def listdir(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""List the contents of a directory, caching them for later lstat calls."""
|
||||
with self.Stdout(self.adb + [b'shell', _sprintf(b'ls -al %s',
|
||||
self.QuoteArgument(path + b'/'))]) as stdout:
|
||||
for line in stdout:
|
||||
if line.startswith(b'total '):
|
||||
continue
|
||||
line = line.rstrip(b'\r\n')
|
||||
try:
|
||||
statdata, filename = self.LsToStat(line)
|
||||
except OSError:
|
||||
continue
|
||||
if filename is None:
|
||||
_print(b'Warning: could not parse %s', line)
|
||||
else:
|
||||
self.stat_cache[path + b'/' + filename] = statdata
|
||||
yield filename
|
||||
|
||||
def lstat(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Stat a file."""
|
||||
if path in self.stat_cache:
|
||||
return self.stat_cache[path]
|
||||
with self.Stdout(self.adb + [b'shell', _sprintf(b'ls -ald %s',
|
||||
self.QuoteArgument(path))]) as stdout:
|
||||
for line in stdout:
|
||||
if line.startswith(b'total '):
|
||||
continue
|
||||
line = line.rstrip(b'\r\n')
|
||||
statdata, filename = self.LsToStat(line)
|
||||
self.stat_cache[path] = statdata
|
||||
return statdata
|
||||
raise OSError('No such file or directory')
|
||||
|
||||
def unlink(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Delete a file."""
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'rm %s',
|
||||
self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('unlink failed')
|
||||
|
||||
def rmdir(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Delete a directory."""
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'rmdir %s',
|
||||
self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('rmdir failed')
|
||||
|
||||
def makedirs(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Create a directory."""
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'mkdir -p %s',
|
||||
self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('mkdir failed')
|
||||
|
||||
def utime(self, path, times):
|
||||
# TODO(rpolzer): Find out why this does not work (returns status 255).
|
||||
"""Set the time of a file to a specified unix time."""
|
||||
atime, mtime = times
|
||||
timestr = time.strftime(b'%Y%m%d.%H%M%S', time.localtime(mtime))
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'touch -mt %s %s',
|
||||
timestr, self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('touch failed')
|
||||
timestr = time.strftime(b'%Y%m%d.%H%M%S', time.localtime(atime))
|
||||
if subprocess.call(self.adb + [b'shell',_sprintf( b'touch -at %s %s',
|
||||
timestr, self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('touch failed')
|
||||
|
||||
def glob(self, path):
|
||||
with self.Stdout(self.adb + [b'shell',
|
||||
_sprintf(b'for p in %s; do echo "$p"; done',
|
||||
path)]) as stdout:
|
||||
for line in stdout:
|
||||
yield line.rstrip(b'\r\n')
|
||||
|
||||
def Push(self, src, dst):
|
||||
"""Push a file from the local file system to the Android device."""
|
||||
if subprocess.call(self.adb + [b'push', src, dst]) != 0:
|
||||
raise OSError('push failed')
|
||||
|
||||
def Pull(self, src, dst):
|
||||
"""Pull a file from the Android device to the local file system."""
|
||||
if subprocess.call(self.adb + [b'pull', src, dst]) != 0:
|
||||
raise OSError('pull failed')
|
||||
|
||||
|
||||
def BuildFileList(fs, path, prefix=b''):
|
||||
"""Builds a file list.
|
||||
|
||||
Args:
|
||||
fs: File system provider (can be os or AdbFileSystem()).
|
||||
path: Initial path.
|
||||
prefix: Path prefix for output file names.
|
||||
|
||||
Yields:
|
||||
File names from path (prefixed by prefix).
|
||||
Directories are yielded before their contents.
|
||||
"""
|
||||
try:
|
||||
statresult = fs.lstat(path)
|
||||
except OSError:
|
||||
return
|
||||
if prefix == b'' and stat.S_ISDIR(statresult.st_mode):
|
||||
yield prefix, statresult
|
||||
try:
|
||||
files = list(fs.listdir(path))
|
||||
except OSError:
|
||||
return
|
||||
files.sort()
|
||||
for n in files:
|
||||
if n == b'.' or n == b'..':
|
||||
continue
|
||||
for t in BuildFileList(fs, path + b'/' + n, prefix + b'/' + n):
|
||||
yield t
|
||||
if stat.S_ISREG(statresult.st_mode):
|
||||
yield prefix, statresult
|
||||
elif stat.S_ISLNK(statresult.st_mode):
|
||||
for t in BuildFileList(fs, os.path.realpath(path), prefix):
|
||||
yield t
|
||||
else:
|
||||
_print(b'Note: unsupported file: %s', path)
|
||||
|
||||
|
||||
def DiffLists(a, b):
|
||||
"""Compares two lists.
|
||||
|
||||
Args:
|
||||
a: the first list.
|
||||
b: the second list.
|
||||
|
||||
Returns:
|
||||
a_only: the items from list a.
|
||||
both: the items from both list, with the remaining tuple items combined.
|
||||
b_only: the items from list b.
|
||||
"""
|
||||
a_only = []
|
||||
b_only = []
|
||||
both = []
|
||||
|
||||
a_iter = iter(a)
|
||||
b_iter = iter(b)
|
||||
a_active = True
|
||||
b_active = True
|
||||
a_available = False
|
||||
b_available = False
|
||||
a_item = None
|
||||
b_item = None
|
||||
|
||||
while a_active and b_active:
|
||||
if not a_available:
|
||||
try:
|
||||
a_item = next(a_iter)
|
||||
a_available = True
|
||||
except StopIteration:
|
||||
a_active = False
|
||||
break
|
||||
if not b_available:
|
||||
try:
|
||||
b_item = next(b_iter)
|
||||
b_available = True
|
||||
except StopIteration:
|
||||
b_active = False
|
||||
break
|
||||
if a_item[0] == b_item[0]:
|
||||
both.append(tuple([a_item[0]] + list(a_item[1:]) + list(b_item[1:])))
|
||||
a_available = False
|
||||
b_available = False
|
||||
elif a_item[0] < b_item[0]:
|
||||
a_only.append(a_item)
|
||||
a_available = False
|
||||
elif a_item[0] > b_item[0]:
|
||||
b_only.append(b_item)
|
||||
b_available = False
|
||||
else:
|
||||
raise
|
||||
|
||||
if a_active:
|
||||
if a_available:
|
||||
a_only.append(a_item)
|
||||
for item in a_iter:
|
||||
a_only.append(item)
|
||||
if b_active:
|
||||
if b_available:
|
||||
b_only.append(b_item)
|
||||
for item in b_iter:
|
||||
b_only.append(item)
|
||||
|
||||
return a_only, both, b_only
|
||||
|
||||
|
||||
class FileSyncer(object):
|
||||
"""File synchronizer."""
|
||||
|
||||
def __init__(self, adb, local_path, remote_path, local_to_remote,
|
||||
remote_to_local, preserve_times, delete_missing, allow_overwrite,
|
||||
allow_replace, dry_run):
|
||||
self.local = local_path
|
||||
self.remote = remote_path
|
||||
self.adb = adb
|
||||
self.local_to_remote = local_to_remote
|
||||
self.remote_to_local = remote_to_local
|
||||
self.preserve_times = preserve_times
|
||||
self.delete_missing = delete_missing
|
||||
self.allow_overwrite = allow_overwrite
|
||||
self.allow_replace = allow_replace
|
||||
self.dry_run = dry_run
|
||||
self.local_only = None
|
||||
self.both = None
|
||||
self.remote_only = None
|
||||
self.num_bytes = 0
|
||||
self.start_time = time.time()
|
||||
|
||||
def IsWorking(self):
|
||||
"""Tests the adb connection."""
|
||||
return self.adb.IsWorking()
|
||||
|
||||
def ScanAndDiff(self):
|
||||
"""Scans the local and remote locations and identifies differences."""
|
||||
_print(b'Scanning and diffing...')
|
||||
locallist = BuildFileList(os, self.local)
|
||||
remotelist = BuildFileList(self.adb, self.remote)
|
||||
self.local_only, self.both, self.remote_only = DiffLists(locallist,
|
||||
remotelist)
|
||||
if not self.local_only and not self.both and not self.remote_only:
|
||||
_print(b'No files seen. User error?')
|
||||
self.src_to_dst = (self.local_to_remote, self.remote_to_local)
|
||||
self.dst_to_src = (self.remote_to_local, self.local_to_remote)
|
||||
self.src_only = (self.local_only, self.remote_only)
|
||||
self.dst_only = (self.remote_only, self.local_only)
|
||||
self.src = (self.local, self.remote)
|
||||
self.dst = (self.remote, self.local)
|
||||
self.dst_fs = (self.adb, os)
|
||||
self.push = (b'Push', b'Pull')
|
||||
self.copy = (self.adb.Push, self.adb.Pull)
|
||||
|
||||
def InterruptProtection(self, fs, name):
|
||||
"""Sets up interrupt protection.
|
||||
|
||||
Usage:
|
||||
with self.InterruptProtection(fs, name):
|
||||
DoSomething()
|
||||
|
||||
If DoSomething() should get interrupted, the file 'name' will be deleted.
|
||||
The exception otherwise will be passed on.
|
||||
|
||||
Args:
|
||||
fs: File system object.
|
||||
name: File name to delete.
|
||||
|
||||
Returns:
|
||||
An object for use by 'with'.
|
||||
"""
|
||||
|
||||
dry_run = self.dry_run
|
||||
|
||||
class DeleteInterruptedFile(object):
|
||||
def __enter__(self):
|
||||
pass
|
||||
|
||||
def __exit__(self, exc_type, exc_value, traceback):
|
||||
if exc_type is not None:
|
||||
_print(b'Interrupted-%s-Delete: %s',
|
||||
b'Pull' if fs == os else b'Push', name)
|
||||
if not dry_run:
|
||||
fs.unlink(name)
|
||||
return False
|
||||
|
||||
return DeleteInterruptedFile()
|
||||
|
||||
def PerformDeletions(self):
|
||||
"""Perform all deleting necessary for the file sync operation."""
|
||||
if not self.delete_missing:
|
||||
return
|
||||
for i in [0, 1]:
|
||||
if self.src_to_dst[i] and not self.dst_to_src[i]:
|
||||
if not self.src_only[i] and not self.both:
|
||||
_print(b'Cowardly refusing to delete everything.')
|
||||
else:
|
||||
for name, s in reversed(self.dst_only[i]):
|
||||
dst_name = self.dst[i] + name
|
||||
_print(b'%s-Delete: %s', self.push[i], dst_name)
|
||||
if stat.S_ISDIR(s.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].rmdir(dst_name)
|
||||
else:
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(dst_name)
|
||||
del self.dst_only[i][:]
|
||||
|
||||
def PerformOverwrites(self):
|
||||
"""Delete files/directories that are in the way for overwriting."""
|
||||
src_only_prepend = ([], [])
|
||||
for name, localstat, remotestat in self.both:
|
||||
if stat.S_ISDIR(localstat.st_mode) and stat.S_ISDIR(remotestat.st_mode):
|
||||
# A dir is a dir is a dir.
|
||||
continue
|
||||
elif stat.S_ISDIR(localstat.st_mode) or stat.S_ISDIR(remotestat.st_mode):
|
||||
# Dir vs file? Nothing to do here yet.
|
||||
pass
|
||||
else:
|
||||
# File vs file? Compare sizes.
|
||||
if localstat.st_size == remotestat.st_size:
|
||||
continue
|
||||
l2r = self.local_to_remote
|
||||
r2l = self.remote_to_local
|
||||
if l2r and r2l:
|
||||
# Truncate times to full minutes, as Android's "ls" only outputs minute
|
||||
# accuracy.
|
||||
localminute = int(localstat.st_mtime / 60)
|
||||
remoteminute = int(remotestat.st_mtime / 60)
|
||||
if localminute > remoteminute:
|
||||
r2l = False
|
||||
elif localminute < remoteminute:
|
||||
l2r = False
|
||||
if l2r and r2l:
|
||||
_print(b'Unresolvable: %s', name)
|
||||
continue
|
||||
if l2r:
|
||||
i = 0 # Local to remote operation.
|
||||
src_stat = localstat
|
||||
dst_stat = remotestat
|
||||
else:
|
||||
i = 1 # Remote to local operation.
|
||||
src_stat = remotestat
|
||||
dst_stat = localstat
|
||||
dst_name = self.dst[i] + name
|
||||
_print(b'%s-Delete-Conflicting: %s', self.push[i], dst_name)
|
||||
if stat.S_ISDIR(localstat.st_mode) or stat.S_ISDIR(remotestat.st_mode):
|
||||
if not self.allow_replace:
|
||||
_print(b'Would have to replace to do this. '
|
||||
b'Use --force to allow this.')
|
||||
continue
|
||||
if not self.allow_overwrite:
|
||||
_print(b'Would have to overwrite to do this, '
|
||||
b'which --no-clobber forbids.')
|
||||
continue
|
||||
if stat.S_ISDIR(dst_stat.st_mode):
|
||||
kill_files = [x for x in self.dst_only[i]
|
||||
if x[0][:len(name) + 1] == name + b'/']
|
||||
self.dst_only[i][:] = [x for x in self.dst_only[i]
|
||||
if x[0][:len(name) + 1] != name + b'/']
|
||||
for l, s in reversed(kill_files):
|
||||
if stat.S_ISDIR(s.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].rmdir(self.dst[i] + l)
|
||||
else:
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(self.dst[i] + l)
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].rmdir(dst_name)
|
||||
elif stat.S_ISDIR(src_stat.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(dst_name)
|
||||
else:
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(dst_name)
|
||||
src_only_prepend[i].append((name, src_stat))
|
||||
for i in [0, 1]:
|
||||
self.src_only[i][:0] = src_only_prepend[i]
|
||||
|
||||
def PerformCopies(self):
|
||||
"""Perform all copying necessary for the file sync operation."""
|
||||
for i in [0, 1]:
|
||||
if self.src_to_dst[i]:
|
||||
for name, s in self.src_only[i]:
|
||||
src_name = self.src[i] + name
|
||||
dst_name = self.dst[i] + name
|
||||
_print(b'%s: %s', self.push[i], dst_name)
|
||||
if stat.S_ISDIR(s.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].makedirs(dst_name)
|
||||
else:
|
||||
with self.InterruptProtection(self.dst_fs[i], dst_name):
|
||||
if not self.dry_run:
|
||||
sys.stderr.write(dst_name + ": ")
|
||||
self.copy[i](src_name, dst_name)
|
||||
self.num_bytes += s.st_size
|
||||
if not self.dry_run:
|
||||
if self.preserve_times:
|
||||
_print(b'%s-Times: accessed %s, modified %s',
|
||||
self.push[i],
|
||||
time.asctime(time.localtime(s.st_atime)).encode('utf-8'),
|
||||
time.asctime(time.localtime(s.st_mtime)).encode('utf-8'))
|
||||
self.dst_fs[i].utime(dst_name, (s.st_atime, s.st_mtime))
|
||||
|
||||
def TimeReport(self):
|
||||
"""Report time and amount of data transferred."""
|
||||
if self.dry_run:
|
||||
_print(b'Total: %d bytes', self.num_bytes)
|
||||
else:
|
||||
end_time = time.time()
|
||||
dt = end_time - self.start_time
|
||||
rate = self.num_bytes / 1024.0 / dt
|
||||
_print(b'Total: %d KB/s (%d bytes in %.3fs)', rate, self.num_bytes, dt)
|
||||
|
||||
|
||||
def ExpandWildcards(globber, path):
|
||||
if path.find(b'?') == -1 and path.find(b'*') == -1 and path.find(b'[') == -1:
|
||||
return [path]
|
||||
return globber.glob(path)
|
||||
|
||||
|
||||
def FixPath(src, dst):
|
||||
# rsync-like path munging to make remote specifications shorter.
|
||||
append = b''
|
||||
pos = src.rfind(b'/')
|
||||
if pos >= 0:
|
||||
if src.endswith(b'/'):
|
||||
# Final slash: copy to the destination "as is".
|
||||
src = src[:-1]
|
||||
else:
|
||||
# No final slash: destination name == source name.
|
||||
append = src[pos:]
|
||||
else:
|
||||
# No slash at all - use same name at destination.
|
||||
append = b'/' + src
|
||||
# Append the destination file name if any.
|
||||
# BUT: do not append "." or ".." components!
|
||||
if append != b'/.' and append != b'/..':
|
||||
dst += append
|
||||
return (src, dst)
|
||||
|
||||
|
||||
def main(*args):
|
||||
parser = argparse.ArgumentParser(
|
||||
description='Synchronize a directory between an Android device and the '+
|
||||
'local file system')
|
||||
parser.add_argument('source', metavar='SRC', type=str, nargs='+',
|
||||
help='The directory to read files/directories from. '+
|
||||
'This must be a local path if -R is not specified, '+
|
||||
'and an Android path if -R is specified. If SRC does '+
|
||||
'not end with a final slash, its last path component '+
|
||||
'is appended to DST (like rsync does).')
|
||||
parser.add_argument('destination', metavar='DST', type=str,
|
||||
help='The directory to write files/directories to. '+
|
||||
'This must be an Android path if -R is not specified, '+
|
||||
'and a local path if -R is specified.')
|
||||
parser.add_argument('-e', '--adb', metavar='COMMAND', default='adb', type=str,
|
||||
help='Use the given adb binary and arguments.')
|
||||
parser.add_argument('--device', action='store_true',
|
||||
help='Directs command to the only connected USB device; '+
|
||||
'returns an error if more than one USB device is '+
|
||||
'present. '+
|
||||
'Corresponds to the "-d" option of adb.')
|
||||
parser.add_argument('--emulator', action='store_true',
|
||||
help='Directs command to the only running emulator; '+
|
||||
'returns an error if more than one emulator is running. '+
|
||||
'Corresponds to the "-e" option of adb.')
|
||||
parser.add_argument('-s', '--serial', metavar='DEVICE', type=str,
|
||||
help='Directs command to the device or emulator with '+
|
||||
'the given serial number or qualifier. Overrides '+
|
||||
'ANDROID_SERIAL environment variable. Use "adb devices" '+
|
||||
'to list all connected devices with their respective '+
|
||||
'serial number. '+
|
||||
'Corresponds to the "-s" option of adb.')
|
||||
parser.add_argument('-H', '--host', metavar='HOST', type=str,
|
||||
help='Name of adb server host (default: localhost). '+
|
||||
'Corresponds to the "-H" option of adb.')
|
||||
parser.add_argument('-P', '--port', metavar='PORT', type=str,
|
||||
help='Port of adb server (default: 5037). '+
|
||||
'Corresponds to the "-P" option of adb.')
|
||||
parser.add_argument('-R', '--reverse', action='store_true',
|
||||
help='Reverse sync (pull, not push).')
|
||||
parser.add_argument('-2', '--two-way', action='store_true',
|
||||
help='Two-way sync (compare modification time; after '+
|
||||
'the sync, both sides will have all files in the '+
|
||||
'respective newest version. This relies on the clocks '+
|
||||
'of your system and the device to match.')
|
||||
#parser.add_argument('-t', '--times', action='store_true',
|
||||
# help='Preserve modification times when copying.')
|
||||
parser.add_argument('-d', '--delete', action='store_true',
|
||||
help='Delete files from DST that are not present on '+
|
||||
'SRC. Mutually exclusive with -2.')
|
||||
parser.add_argument('-f', '--force', action='store_true',
|
||||
help='Allow deleting files/directories when having to '+
|
||||
'replace a file by a directory or vice versa. This is '+
|
||||
'disabled by default to prevent large scale accidents.')
|
||||
parser.add_argument('-n', '--no-clobber', action='store_true',
|
||||
help='Do not ever overwrite any '+
|
||||
'existing files. Mutually exclusive with -f.')
|
||||
parser.add_argument('--dry-run',action='store_true',
|
||||
help='Do not do anything - just show what would '+
|
||||
'be done.')
|
||||
args = parser.parse_args()
|
||||
args_encoding = locale.getdefaultlocale()[1]
|
||||
|
||||
localpatterns = [x.encode(args_encoding) for x in args.source]
|
||||
remotepath = args.destination.encode(args_encoding)
|
||||
adb = args.adb.encode(args_encoding).split(b' ')
|
||||
if args.device:
|
||||
adb += [b'-d']
|
||||
if args.emulator:
|
||||
adb += [b'-e']
|
||||
if args.serial != None:
|
||||
adb += [b'-s', args.serial.encode(args_encoding)]
|
||||
if args.host != None:
|
||||
adb += [b'-H', args.host.encode(args_encoding)]
|
||||
if args.port != None:
|
||||
adb += [b'-P', args.port.encode(args_encoding)]
|
||||
adb = AdbFileSystem(adb)
|
||||
|
||||
# Expand wildcards.
|
||||
localpaths = []
|
||||
remotepaths = []
|
||||
if args.reverse:
|
||||
for pattern in localpatterns:
|
||||
for src in ExpandWildcards(adb, pattern):
|
||||
src, dst = FixPath(src, remotepath)
|
||||
localpaths.append(src)
|
||||
remotepaths.append(dst)
|
||||
else:
|
||||
for src in localpatterns:
|
||||
src, dst = FixPath(src, remotepath)
|
||||
localpaths.append(src)
|
||||
remotepaths.append(dst)
|
||||
|
||||
preserve_times = False # args.times
|
||||
delete_missing = args.delete
|
||||
allow_replace = args.force
|
||||
allow_overwrite = not args.no_clobber
|
||||
dry_run = args.dry_run
|
||||
local_to_remote = True
|
||||
remote_to_local = False
|
||||
if args.two_way:
|
||||
local_to_remote = True
|
||||
remote_to_local = True
|
||||
if args.reverse:
|
||||
local_to_remote, remote_to_local = remote_to_local, local_to_remote
|
||||
localpaths, remotepaths = remotepaths, localpaths
|
||||
if allow_replace and not allow_overwrite:
|
||||
_print(b'--no-clobber and --force are mutually exclusive.')
|
||||
parser.print_help()
|
||||
return
|
||||
if delete_missing and local_to_remote and remote_to_local:
|
||||
_print(b'--delete and --two-way are mutually exclusive.')
|
||||
parser.print_help()
|
||||
return
|
||||
|
||||
# Two-way sync is only allowed with disjoint remote and local path sets.
|
||||
if (remote_to_local and local_to_remote) or delete_missing:
|
||||
if ((remote_to_local and len(localpaths) != len(set(localpaths))) or
|
||||
(local_to_remote and len(remotepaths) != len(set(remotepaths)))):
|
||||
_print(b'--two-way and --delete are only supported for disjoint sets of '
|
||||
b'source and destination paths (in other words, all SRC must '
|
||||
b'differ in basename).')
|
||||
parser.print_help()
|
||||
return
|
||||
|
||||
for i in range(len(localpaths)):
|
||||
_print(b'Sync: local %s, remote %s', localpaths[i], remotepaths[i])
|
||||
syncer = FileSyncer(adb, localpaths[i], remotepaths[i],
|
||||
local_to_remote, remote_to_local, preserve_times,
|
||||
delete_missing, allow_overwrite, allow_replace, dry_run)
|
||||
if not syncer.IsWorking():
|
||||
_print(b'Device not connected or not working.')
|
||||
return
|
||||
try:
|
||||
syncer.ScanAndDiff()
|
||||
syncer.PerformDeletions()
|
||||
syncer.PerformOverwrites()
|
||||
syncer.PerformCopies()
|
||||
finally:
|
||||
syncer.TimeReport()
|
||||
|
||||
if __name__ == '__main__':
|
||||
main(*sys.argv)
|
||||
|
|
@ -0,0 +1,777 @@
|
|||
#!/usr/bin/python
|
||||
|
||||
# Copyright 2014 Google Inc. All rights reserved.
|
||||
#
|
||||
# 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.
|
||||
|
||||
"""Sync files from/to an Android device."""
|
||||
|
||||
from __future__ import unicode_literals
|
||||
import argparse
|
||||
import glob
|
||||
import locale
|
||||
import os
|
||||
import re
|
||||
import stat
|
||||
import subprocess
|
||||
import sys
|
||||
import time
|
||||
|
||||
|
||||
def _sprintf(s, *args):
|
||||
# To be able to use string formatting, we first have to covert to
|
||||
# unicode strings; however, we must do so in a way that preserves all
|
||||
# bytes, and convert back at the end. An encoding that maps all byte
|
||||
# values to different Unicode codepoints is cp437.
|
||||
return (s.decode('cp437') % tuple([
|
||||
(x.decode('cp437') if type(x) == bytes else x) for x in args
|
||||
])).encode('cp437')
|
||||
|
||||
|
||||
def _print(s, *args):
|
||||
"""Writes a binary string to stdout.
|
||||
|
||||
Args:
|
||||
s: The binary format string to write.
|
||||
args: The args for the format string.
|
||||
"""
|
||||
if hasattr(sys.stdout, 'buffer'):
|
||||
# Python 3.
|
||||
sys.stdout.buffer.write(_sprintf(s, *args) + b'\n')
|
||||
sys.stdout.buffer.flush()
|
||||
else:
|
||||
# Python 2.
|
||||
sys.stdout.write(_sprintf(s, *args) + b'\n')
|
||||
|
||||
|
||||
class AdbFileSystem(object):
|
||||
"""Mimics os's file interface but uses the adb utility."""
|
||||
|
||||
def __init__(self, adb):
|
||||
self.stat_cache = {}
|
||||
self.adb = adb
|
||||
|
||||
# Regarding parsing stat results, we only care for the following fields:
|
||||
# - st_size
|
||||
# - st_mtime
|
||||
# - st_mode (but only about S_ISDIR and S_ISREG properties)
|
||||
# Therefore, we only capture parts of 'ls -l' output that we actually use.
|
||||
# The other fields will be filled with dummy values.
|
||||
LS_TO_STAT_RE = re.compile(br'''^
|
||||
(?:
|
||||
(?P<S_IFREG> -) |
|
||||
(?P<S_IFBLK> b) |
|
||||
(?P<S_IFCHR> c) |
|
||||
(?P<S_IFDIR> d) |
|
||||
(?P<S_IFLNK> l) |
|
||||
(?P<S_IFIFO> p) |
|
||||
(?P<S_IFSOCK> s))
|
||||
[-r][-w][-xsS]
|
||||
[-r][-w][-xsS]
|
||||
[-r][-w][-xtT] # Mode string.
|
||||
[ ]+
|
||||
(?:
|
||||
[0-9]+ # number of hard links
|
||||
[ ]+
|
||||
)?
|
||||
[^ ]+ # User name/ID.
|
||||
[ ]+
|
||||
[^ ]+ # Group name/ID.
|
||||
[ ]+
|
||||
(?(S_IFBLK) [^ ]+[ ]+[^ ]+[ ]+) # Device numbers.
|
||||
(?(S_IFCHR) [^ ]+[ ]+[^ ]+[ ]+) # Device numbers.
|
||||
(?(S_IFDIR) [0-9]+ [ ]+)? # directory Size.
|
||||
(?(S_IFREG)
|
||||
(?P<st_size> [0-9]+) # Size.
|
||||
[ ]+)
|
||||
(?P<st_mtime>
|
||||
[0-9]{4}-[0-9]{2}-[0-9]{2} # Date.
|
||||
[ ]
|
||||
[0-9]{2}:[0-9]{2}) # Time.
|
||||
[ ]
|
||||
# Don't capture filename for symlinks (ambiguous).
|
||||
(?(S_IFLNK) .* | (?P<filename> .*))
|
||||
$''', re.DOTALL | re.VERBOSE)
|
||||
def LsToStat(self, line):
|
||||
"""Convert a line from 'ls -l' output to a stat result.
|
||||
|
||||
Args:
|
||||
line: Output line of 'ls -l' on Android.
|
||||
|
||||
Returns:
|
||||
os.stat_result for the line.
|
||||
|
||||
Raises:
|
||||
OSError: if the given string is not a 'ls -l' output line (but maybe an
|
||||
error message instead).
|
||||
"""
|
||||
|
||||
match = self.LS_TO_STAT_RE.match(line)
|
||||
if match is None:
|
||||
_print(b'Warning: could not parse %r.', line)
|
||||
raise OSError('Unparseable ls -al result.')
|
||||
groups = match.groupdict()
|
||||
|
||||
# Get the values we're interested in.
|
||||
st_mode = ( # 0755
|
||||
stat.S_IRWXU | stat.S_IRGRP | stat.S_IXGRP | stat.S_IROTH | stat.S_IXOTH)
|
||||
if groups['S_IFREG']: st_mode |= stat.S_IFREG
|
||||
if groups['S_IFBLK']: st_mode |= stat.S_IFBLK
|
||||
if groups['S_IFCHR']: st_mode |= stat.S_IFCHR
|
||||
if groups['S_IFDIR']: st_mode |= stat.S_IFDIR
|
||||
if groups['S_IFIFO']: st_mode |= stat.S_IFIFO
|
||||
if groups['S_IFLNK']: st_mode |= stat.S_IFLNK
|
||||
if groups['S_IFSOCK']: st_mode |= stat.S_IFSOCK
|
||||
st_size = groups['st_size']
|
||||
if st_size is not None:
|
||||
st_size = int(st_size)
|
||||
st_mtime = time.mktime(time.strptime(match.group('st_mtime').decode('utf-8'),
|
||||
'%Y-%m-%d %H:%M'))
|
||||
|
||||
# Fill the rest with dummy values.
|
||||
st_ino = 1
|
||||
st_rdev = 0
|
||||
st_nlink = 1
|
||||
st_uid = -2 # Nobody.
|
||||
st_gid = -2 # Nobody.
|
||||
st_atime = st_ctime = st_mtime
|
||||
|
||||
stbuf = os.stat_result((st_mode, st_ino, st_rdev, st_nlink, st_uid, st_gid,
|
||||
st_size, st_atime, st_mtime, st_ctime))
|
||||
filename = groups['filename']
|
||||
return stbuf, filename
|
||||
|
||||
def Stdout(self, *popen_args):
|
||||
"""Closes the process's stdout when done.
|
||||
|
||||
Usage:
|
||||
with Stdout(...) as stdout:
|
||||
DoSomething(stdout)
|
||||
|
||||
Args:
|
||||
popen_args: Arguments for subprocess.Popen; stdout=PIPE is implicitly
|
||||
added.
|
||||
|
||||
Returns:
|
||||
An object for use by 'with'.
|
||||
"""
|
||||
|
||||
class Stdout(object):
|
||||
def __init__(self, popen):
|
||||
self.popen = popen
|
||||
|
||||
def __enter__(self):
|
||||
return self.popen.stdout
|
||||
|
||||
def __exit__(self, exc_type, exc_value, traceback):
|
||||
self.popen.stdout.close()
|
||||
if self.popen.wait() != 0:
|
||||
raise OSError('Subprocess exited with nonzero status.')
|
||||
return False
|
||||
|
||||
return Stdout(subprocess.Popen(*popen_args, stdout=subprocess.PIPE))
|
||||
|
||||
def QuoteArgument(self, arg):
|
||||
# Quotes an argument for use by adb shell.
|
||||
# Usually, arguments in 'adb shell' use are put in double quotes by adb,
|
||||
# but not in any way escaped.
|
||||
arg = arg.replace(b'\\', b'\\\\')
|
||||
arg = arg.replace(b'"', b'\\"')
|
||||
arg = arg.replace(b'$', b'\\$')
|
||||
arg = arg.replace(b'`', b'\\`')
|
||||
arg = b'"' + arg + b'"'
|
||||
return arg
|
||||
|
||||
def IsWorking(self):
|
||||
"""Tests the adb connection."""
|
||||
# This string should contain all possible evil, but no percent signs.
|
||||
# Note this code uses 'date' and not 'echo', as date just calls strftime
|
||||
# while echo does its own backslash escape handling additionally to the
|
||||
# shell's. Too bad printf "%s\n" is not available.
|
||||
test_strings = [
|
||||
b'(',
|
||||
b'(; #`ls`$PATH\'"(\\\\\\\\){};!\xc0\xaf\xff\xc2\xbf'
|
||||
]
|
||||
for test_string in test_strings:
|
||||
good = False
|
||||
with self.Stdout(self.adb + [b'shell', _sprintf(b'date +%s',
|
||||
self.QuoteArgument(test_string))]) as stdout:
|
||||
for line in stdout:
|
||||
line = line.rstrip(b'\r\n')
|
||||
if line == test_string:
|
||||
good = True
|
||||
if not good:
|
||||
return False
|
||||
return True
|
||||
|
||||
def listdir(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""List the contents of a directory, caching them for later lstat calls."""
|
||||
with self.Stdout(self.adb + [b'shell', _sprintf(b'ls -al %s',
|
||||
self.QuoteArgument(path + b'/'))]) as stdout:
|
||||
for line in stdout:
|
||||
if line.startswith(b'total '):
|
||||
continue
|
||||
line = line.rstrip(b'\r\n')
|
||||
try:
|
||||
statdata, filename = self.LsToStat(line)
|
||||
except OSError:
|
||||
continue
|
||||
if filename is None:
|
||||
_print(b'Warning: could not parse %s', line)
|
||||
else:
|
||||
self.stat_cache[path + b'/' + filename] = statdata
|
||||
yield filename
|
||||
|
||||
def lstat(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Stat a file."""
|
||||
if path in self.stat_cache:
|
||||
return self.stat_cache[path]
|
||||
with self.Stdout(self.adb + [b'shell', _sprintf(b'ls -ald %s',
|
||||
self.QuoteArgument(path))]) as stdout:
|
||||
for line in stdout:
|
||||
if line.startswith(b'total '):
|
||||
continue
|
||||
line = line.rstrip(b'\r\n')
|
||||
statdata, filename = self.LsToStat(line)
|
||||
self.stat_cache[path] = statdata
|
||||
return statdata
|
||||
raise OSError('No such file or directory')
|
||||
|
||||
def unlink(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Delete a file."""
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'rm %s',
|
||||
self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('unlink failed')
|
||||
|
||||
def rmdir(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Delete a directory."""
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'rmdir %s',
|
||||
self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('rmdir failed')
|
||||
|
||||
def makedirs(self, path): # os's name, so pylint: disable=g-bad-name
|
||||
"""Create a directory."""
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'mkdir -p %s',
|
||||
self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('mkdir failed')
|
||||
|
||||
def utime(self, path, times):
|
||||
# TODO(rpolzer): Find out why this does not work (returns status 255).
|
||||
"""Set the time of a file to a specified unix time."""
|
||||
atime, mtime = times
|
||||
timestr = time.strftime(b'%Y%m%d.%H%M%S', time.localtime(mtime))
|
||||
if subprocess.call(self.adb + [b'shell', _sprintf(b'touch -mt %s %s',
|
||||
timestr, self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('touch failed')
|
||||
timestr = time.strftime(b'%Y%m%d.%H%M%S', time.localtime(atime))
|
||||
if subprocess.call(self.adb + [b'shell',_sprintf( b'touch -at %s %s',
|
||||
timestr, self.QuoteArgument(path))]) != 0:
|
||||
raise OSError('touch failed')
|
||||
|
||||
def glob(self, path):
|
||||
with self.Stdout(self.adb + [b'shell',
|
||||
_sprintf(b'for p in %s; do echo "$p"; done',
|
||||
path)]) as stdout:
|
||||
for line in stdout:
|
||||
yield line.rstrip(b'\r\n')
|
||||
|
||||
def Push(self, src, dst):
|
||||
"""Push a file from the local file system to the Android device."""
|
||||
if subprocess.call(self.adb + [b'push', src, dst]) != 0:
|
||||
raise OSError('push failed')
|
||||
|
||||
def Pull(self, src, dst):
|
||||
"""Pull a file from the Android device to the local file system."""
|
||||
if subprocess.call(self.adb + [b'pull', src, dst]) != 0:
|
||||
raise OSError('pull failed')
|
||||
|
||||
|
||||
def BuildFileList(fs, path, prefix=b''):
|
||||
"""Builds a file list.
|
||||
|
||||
Args:
|
||||
fs: File system provider (can be os or AdbFileSystem()).
|
||||
path: Initial path.
|
||||
prefix: Path prefix for output file names.
|
||||
|
||||
Yields:
|
||||
File names from path (prefixed by prefix).
|
||||
Directories are yielded before their contents.
|
||||
"""
|
||||
try:
|
||||
statresult = fs.lstat(path)
|
||||
except OSError:
|
||||
return
|
||||
if stat.S_ISDIR(statresult.st_mode):
|
||||
yield prefix, statresult
|
||||
try:
|
||||
files = list(fs.listdir(path))
|
||||
except OSError:
|
||||
return
|
||||
files.sort()
|
||||
for n in files:
|
||||
if n == b'.' or n == b'..':
|
||||
continue
|
||||
for t in BuildFileList(fs, path + b'/' + n, prefix + b'/' + n):
|
||||
yield t
|
||||
elif stat.S_ISREG(statresult.st_mode):
|
||||
yield prefix, statresult
|
||||
elif stat.S_ISLNK(statresult.st_mode):
|
||||
for t in BuildFileList(fs, os.path.realpath(path), prefix):
|
||||
yield t
|
||||
else:
|
||||
_print(b'Note: unsupported file: %s', path)
|
||||
|
||||
|
||||
def DiffLists(a, b):
|
||||
"""Compares two lists.
|
||||
|
||||
Args:
|
||||
a: the first list.
|
||||
b: the second list.
|
||||
|
||||
Returns:
|
||||
a_only: the items from list a.
|
||||
both: the items from both list, with the remaining tuple items combined.
|
||||
b_only: the items from list b.
|
||||
"""
|
||||
a_only = []
|
||||
b_only = []
|
||||
both = []
|
||||
|
||||
a_iter = iter(a)
|
||||
b_iter = iter(b)
|
||||
a_active = True
|
||||
b_active = True
|
||||
a_available = False
|
||||
b_available = False
|
||||
a_item = None
|
||||
b_item = None
|
||||
|
||||
while a_active and b_active:
|
||||
if not a_available:
|
||||
try:
|
||||
a_item = next(a_iter)
|
||||
a_available = True
|
||||
except StopIteration:
|
||||
a_active = False
|
||||
break
|
||||
if not b_available:
|
||||
try:
|
||||
b_item = next(b_iter)
|
||||
b_available = True
|
||||
except StopIteration:
|
||||
b_active = False
|
||||
break
|
||||
if a_item[0] == b_item[0]:
|
||||
both.append(tuple([a_item[0]] + list(a_item[1:]) + list(b_item[1:])))
|
||||
a_available = False
|
||||
b_available = False
|
||||
elif a_item[0] < b_item[0]:
|
||||
a_only.append(a_item)
|
||||
a_available = False
|
||||
elif a_item[0] > b_item[0]:
|
||||
b_only.append(b_item)
|
||||
b_available = False
|
||||
else:
|
||||
raise
|
||||
|
||||
if a_active:
|
||||
if a_available:
|
||||
a_only.append(a_item)
|
||||
for item in a_iter:
|
||||
a_only.append(item)
|
||||
if b_active:
|
||||
if b_available:
|
||||
b_only.append(b_item)
|
||||
for item in b_iter:
|
||||
b_only.append(item)
|
||||
|
||||
return a_only, both, b_only
|
||||
|
||||
|
||||
class FileSyncer(object):
|
||||
"""File synchronizer."""
|
||||
|
||||
def __init__(self, adb, local_path, remote_path, local_to_remote,
|
||||
remote_to_local, preserve_times, delete_missing, allow_overwrite,
|
||||
allow_replace, dry_run):
|
||||
self.local = local_path
|
||||
self.remote = remote_path
|
||||
self.adb = adb
|
||||
self.local_to_remote = local_to_remote
|
||||
self.remote_to_local = remote_to_local
|
||||
self.preserve_times = preserve_times
|
||||
self.delete_missing = delete_missing
|
||||
self.allow_overwrite = allow_overwrite
|
||||
self.allow_replace = allow_replace
|
||||
self.dry_run = dry_run
|
||||
self.local_only = None
|
||||
self.both = None
|
||||
self.remote_only = None
|
||||
self.num_bytes = 0
|
||||
self.start_time = time.time()
|
||||
|
||||
def IsWorking(self):
|
||||
"""Tests the adb connection."""
|
||||
return self.adb.IsWorking()
|
||||
|
||||
def ScanAndDiff(self):
|
||||
"""Scans the local and remote locations and identifies differences."""
|
||||
_print(b'Scanning and diffing...')
|
||||
locallist = BuildFileList(os, self.local)
|
||||
remotelist = BuildFileList(self.adb, self.remote)
|
||||
self.local_only, self.both, self.remote_only = DiffLists(locallist,
|
||||
remotelist)
|
||||
if not self.local_only and not self.both and not self.remote_only:
|
||||
_print(b'No files seen. User error?')
|
||||
self.src_to_dst = (self.local_to_remote, self.remote_to_local)
|
||||
self.dst_to_src = (self.remote_to_local, self.local_to_remote)
|
||||
self.src_only = (self.local_only, self.remote_only)
|
||||
self.dst_only = (self.remote_only, self.local_only)
|
||||
self.src = (self.local, self.remote)
|
||||
self.dst = (self.remote, self.local)
|
||||
self.dst_fs = (self.adb, os)
|
||||
self.push = (b'Push', b'Pull')
|
||||
self.copy = (self.adb.Push, self.adb.Pull)
|
||||
|
||||
def InterruptProtection(self, fs, name):
|
||||
"""Sets up interrupt protection.
|
||||
|
||||
Usage:
|
||||
with self.InterruptProtection(fs, name):
|
||||
DoSomething()
|
||||
|
||||
If DoSomething() should get interrupted, the file 'name' will be deleted.
|
||||
The exception otherwise will be passed on.
|
||||
|
||||
Args:
|
||||
fs: File system object.
|
||||
name: File name to delete.
|
||||
|
||||
Returns:
|
||||
An object for use by 'with'.
|
||||
"""
|
||||
|
||||
dry_run = self.dry_run
|
||||
|
||||
class DeleteInterruptedFile(object):
|
||||
def __enter__(self):
|
||||
pass
|
||||
|
||||
def __exit__(self, exc_type, exc_value, traceback):
|
||||
if exc_type is not None:
|
||||
_print(b'Interrupted-%s-Delete: %s',
|
||||
b'Pull' if fs == os else b'Push', name)
|
||||
if not dry_run:
|
||||
fs.unlink(name)
|
||||
return False
|
||||
|
||||
return DeleteInterruptedFile()
|
||||
|
||||
def PerformDeletions(self):
|
||||
"""Perform all deleting necessary for the file sync operation."""
|
||||
if not self.delete_missing:
|
||||
return
|
||||
for i in [0, 1]:
|
||||
if self.src_to_dst[i] and not self.dst_to_src[i]:
|
||||
if not self.src_only[i] and not self.both:
|
||||
_print(b'Cowardly refusing to delete everything.')
|
||||
else:
|
||||
for name, s in reversed(self.dst_only[i]):
|
||||
dst_name = self.dst[i] + name
|
||||
_print(b'%s-Delete: %s', self.push[i], dst_name)
|
||||
if stat.S_ISDIR(s.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].rmdir(dst_name)
|
||||
else:
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(dst_name)
|
||||
del self.dst_only[i][:]
|
||||
|
||||
def PerformOverwrites(self):
|
||||
"""Delete files/directories that are in the way for overwriting."""
|
||||
src_only_prepend = ([], [])
|
||||
for name, localstat, remotestat in self.both:
|
||||
if stat.S_ISDIR(localstat.st_mode) and stat.S_ISDIR(remotestat.st_mode):
|
||||
# A dir is a dir is a dir.
|
||||
continue
|
||||
elif stat.S_ISDIR(localstat.st_mode) or stat.S_ISDIR(remotestat.st_mode):
|
||||
# Dir vs file? Nothing to do here yet.
|
||||
pass
|
||||
else:
|
||||
# File vs file? Compare sizes.
|
||||
if localstat.st_size == remotestat.st_size:
|
||||
continue
|
||||
l2r = self.local_to_remote
|
||||
r2l = self.remote_to_local
|
||||
if l2r and r2l:
|
||||
# Truncate times to full minutes, as Android's "ls" only outputs minute
|
||||
# accuracy.
|
||||
localminute = int(localstat.st_mtime / 60)
|
||||
remoteminute = int(remotestat.st_mtime / 60)
|
||||
if localminute > remoteminute:
|
||||
r2l = False
|
||||
elif localminute < remoteminute:
|
||||
l2r = False
|
||||
if l2r and r2l:
|
||||
_print(b'Unresolvable: %s', name)
|
||||
continue
|
||||
if l2r:
|
||||
i = 0 # Local to remote operation.
|
||||
src_stat = localstat
|
||||
dst_stat = remotestat
|
||||
else:
|
||||
i = 1 # Remote to local operation.
|
||||
src_stat = remotestat
|
||||
dst_stat = localstat
|
||||
dst_name = self.dst[i] + name
|
||||
_print(b'%s-Delete-Conflicting: %s', self.push[i], dst_name)
|
||||
if stat.S_ISDIR(localstat.st_mode) or stat.S_ISDIR(remotestat.st_mode):
|
||||
if not self.allow_replace:
|
||||
_print(b'Would have to replace to do this. '
|
||||
b'Use --force to allow this.')
|
||||
continue
|
||||
if not self.allow_overwrite:
|
||||
_print(b'Would have to overwrite to do this, '
|
||||
b'which --no-clobber forbids.')
|
||||
continue
|
||||
if stat.S_ISDIR(dst_stat.st_mode):
|
||||
kill_files = [x for x in self.dst_only[i]
|
||||
if x[0][:len(name) + 1] == name + b'/']
|
||||
self.dst_only[i][:] = [x for x in self.dst_only[i]
|
||||
if x[0][:len(name) + 1] != name + b'/']
|
||||
for l, s in reversed(kill_files):
|
||||
if stat.S_ISDIR(s.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].rmdir(self.dst[i] + l)
|
||||
else:
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(self.dst[i] + l)
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].rmdir(dst_name)
|
||||
elif stat.S_ISDIR(src_stat.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(dst_name)
|
||||
else:
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].unlink(dst_name)
|
||||
src_only_prepend[i].append((name, src_stat))
|
||||
for i in [0, 1]:
|
||||
self.src_only[i][:0] = src_only_prepend[i]
|
||||
|
||||
def PerformCopies(self):
|
||||
"""Perform all copying necessary for the file sync operation."""
|
||||
for i in [0, 1]:
|
||||
if self.src_to_dst[i]:
|
||||
for name, s in self.src_only[i]:
|
||||
src_name = self.src[i] + name
|
||||
dst_name = self.dst[i] + name
|
||||
_print(b'%s: %s', self.push[i], dst_name)
|
||||
if stat.S_ISDIR(s.st_mode):
|
||||
if not self.dry_run:
|
||||
self.dst_fs[i].makedirs(dst_name)
|
||||
else:
|
||||
with self.InterruptProtection(self.dst_fs[i], dst_name):
|
||||
if not self.dry_run:
|
||||
self.copy[i](src_name, dst_name)
|
||||
self.num_bytes += s.st_size
|
||||
if not self.dry_run:
|
||||
if self.preserve_times:
|
||||
_print(b'%s-Times: accessed %s, modified %s',
|
||||
self.push[i],
|
||||
time.asctime(time.localtime(s.st_atime)).encode('utf-8'),
|
||||
time.asctime(time.localtime(s.st_mtime)).encode('utf-8'))
|
||||
self.dst_fs[i].utime(dst_name, (s.st_atime, s.st_mtime))
|
||||
|
||||
def TimeReport(self):
|
||||
"""Report time and amount of data transferred."""
|
||||
if self.dry_run:
|
||||
_print(b'Total: %d bytes', self.num_bytes)
|
||||
else:
|
||||
end_time = time.time()
|
||||
dt = end_time - self.start_time
|
||||
rate = self.num_bytes / 1024.0 / dt
|
||||
_print(b'Total: %d KB/s (%d bytes in %.3fs)', rate, self.num_bytes, dt)
|
||||
|
||||
|
||||
def ExpandWildcards(globber, path):
|
||||
if path.find(b'?') == -1 and path.find(b'*') == -1 and path.find(b'[') == -1:
|
||||
return [path]
|
||||
return globber.glob(path)
|
||||
|
||||
|
||||
def FixPath(src, dst):
|
||||
# rsync-like path munging to make remote specifications shorter.
|
||||
append = b''
|
||||
pos = src.rfind(b'/')
|
||||
if pos >= 0:
|
||||
if src.endswith(b'/'):
|
||||
# Final slash: copy to the destination "as is".
|
||||
src = src[:-1]
|
||||
else:
|
||||
# No final slash: destination name == source name.
|
||||
append = src[pos:]
|
||||
else:
|
||||
# No slash at all - use same name at destination.
|
||||
append = b'/' + src
|
||||
# Append the destination file name if any.
|
||||
# BUT: do not append "." or ".." components!
|
||||
if append != b'/.' and append != b'/..':
|
||||
dst += append
|
||||
return (src, dst)
|
||||
|
||||
|
||||
def main(*args):
|
||||
parser = argparse.ArgumentParser(
|
||||
description='Synchronize a directory between an Android device and the '+
|
||||
'local file system')
|
||||
parser.add_argument('source', metavar='SRC', type=str, nargs='+',
|
||||
help='The directory to read files/directories from. '+
|
||||
'This must be a local path if -R is not specified, '+
|
||||
'and an Android path if -R is specified. If SRC does '+
|
||||
'not end with a final slash, its last path component '+
|
||||
'is appended to DST (like rsync does).')
|
||||
parser.add_argument('destination', metavar='DST', type=str,
|
||||
help='The directory to write files/directories to. '+
|
||||
'This must be an Android path if -R is not specified, '+
|
||||
'and a local path if -R is specified.')
|
||||
parser.add_argument('-e', '--adb', metavar='COMMAND', default='adb', type=str,
|
||||
help='Use the given adb binary and arguments.')
|
||||
parser.add_argument('--device', action='store_true',
|
||||
help='Directs command to the only connected USB device; '+
|
||||
'returns an error if more than one USB device is '+
|
||||
'present. '+
|
||||
'Corresponds to the "-d" option of adb.')
|
||||
parser.add_argument('--emulator', action='store_true',
|
||||
help='Directs command to the only running emulator; '+
|
||||
'returns an error if more than one emulator is running. '+
|
||||
'Corresponds to the "-e" option of adb.')
|
||||
parser.add_argument('-s', '--serial', metavar='DEVICE', type=str,
|
||||
help='Directs command to the device or emulator with '+
|
||||
'the given serial number or qualifier. Overrides '+
|
||||
'ANDROID_SERIAL environment variable. Use "adb devices" '+
|
||||
'to list all connected devices with their respective '+
|
||||
'serial number. '+
|
||||
'Corresponds to the "-s" option of adb.')
|
||||
parser.add_argument('-H', '--host', metavar='HOST', type=str,
|
||||
help='Name of adb server host (default: localhost). '+
|
||||
'Corresponds to the "-H" option of adb.')
|
||||
parser.add_argument('-P', '--port', metavar='PORT', type=str,
|
||||
help='Port of adb server (default: 5037). '+
|
||||
'Corresponds to the "-P" option of adb.')
|
||||
parser.add_argument('-R', '--reverse', action='store_true',
|
||||
help='Reverse sync (pull, not push).')
|
||||
parser.add_argument('-2', '--two-way', action='store_true',
|
||||
help='Two-way sync (compare modification time; after '+
|
||||
'the sync, both sides will have all files in the '+
|
||||
'respective newest version. This relies on the clocks '+
|
||||
'of your system and the device to match.')
|
||||
#parser.add_argument('-t', '--times', action='store_true',
|
||||
# help='Preserve modification times when copying.')
|
||||
parser.add_argument('-d', '--delete', action='store_true',
|
||||
help='Delete files from DST that are not present on '+
|
||||
'SRC. Mutually exclusive with -2.')
|
||||
parser.add_argument('-f', '--force', action='store_true',
|
||||
help='Allow deleting files/directories when having to '+
|
||||
'replace a file by a directory or vice versa. This is '+
|
||||
'disabled by default to prevent large scale accidents.')
|
||||
parser.add_argument('-n', '--no-clobber', action='store_true',
|
||||
help='Do not ever overwrite any '+
|
||||
'existing files. Mutually exclusive with -f.')
|
||||
parser.add_argument('--dry-run',action='store_true',
|
||||
help='Do not do anything - just show what would '+
|
||||
'be done.')
|
||||
args = parser.parse_args()
|
||||
args_encoding = locale.getdefaultlocale()[1]
|
||||
|
||||
localpatterns = [x.encode(args_encoding) for x in args.source]
|
||||
remotepath = args.destination.encode(args_encoding)
|
||||
adb = args.adb.encode(args_encoding).split(b' ')
|
||||
if args.device:
|
||||
adb += [b'-d']
|
||||
if args.emulator:
|
||||
adb += [b'-e']
|
||||
if args.serial != None:
|
||||
adb += [b'-s', args.serial.encode(args_encoding)]
|
||||
if args.host != None:
|
||||
adb += [b'-H', args.host.encode(args_encoding)]
|
||||
if args.port != None:
|
||||
adb += [b'-P', args.port.encode(args_encoding)]
|
||||
adb = AdbFileSystem(adb)
|
||||
|
||||
# Expand wildcards.
|
||||
localpaths = []
|
||||
remotepaths = []
|
||||
if args.reverse:
|
||||
for pattern in localpatterns:
|
||||
for src in ExpandWildcards(adb, pattern):
|
||||
src, dst = FixPath(src, remotepath)
|
||||
localpaths.append(src)
|
||||
remotepaths.append(dst)
|
||||
else:
|
||||
for src in localpatterns:
|
||||
src, dst = FixPath(src, remotepath)
|
||||
localpaths.append(src)
|
||||
remotepaths.append(dst)
|
||||
|
||||
preserve_times = False # args.times
|
||||
delete_missing = args.delete
|
||||
allow_replace = args.force
|
||||
allow_overwrite = not args.no_clobber
|
||||
dry_run = args.dry_run
|
||||
local_to_remote = True
|
||||
remote_to_local = False
|
||||
if args.two_way:
|
||||
local_to_remote = True
|
||||
remote_to_local = True
|
||||
if args.reverse:
|
||||
local_to_remote, remote_to_local = remote_to_local, local_to_remote
|
||||
localpaths, remotepaths = remotepaths, localpaths
|
||||
if allow_replace and not allow_overwrite:
|
||||
_print(b'--no-clobber and --force are mutually exclusive.')
|
||||
parser.print_help()
|
||||
return
|
||||
if delete_missing and local_to_remote and remote_to_local:
|
||||
_print(b'--delete and --two-way are mutually exclusive.')
|
||||
parser.print_help()
|
||||
return
|
||||
|
||||
# Two-way sync is only allowed with disjoint remote and local path sets.
|
||||
if (remote_to_local and local_to_remote) or delete_missing:
|
||||
if ((remote_to_local and len(localpaths) != len(set(localpaths))) or
|
||||
(local_to_remote and len(remotepaths) != len(set(remotepaths)))):
|
||||
_print(b'--two-way and --delete are only supported for disjoint sets of '
|
||||
b'source and destination paths (in other words, all SRC must '
|
||||
b'differ in basename).')
|
||||
parser.print_help()
|
||||
return
|
||||
|
||||
for i in range(len(localpaths)):
|
||||
_print(b'Sync: local %s, remote %s', localpaths[i], remotepaths[i])
|
||||
syncer = FileSyncer(adb, localpaths[i], remotepaths[i],
|
||||
local_to_remote, remote_to_local, preserve_times,
|
||||
delete_missing, allow_overwrite, allow_replace, dry_run)
|
||||
if not syncer.IsWorking():
|
||||
_print(b'Device not connected or not working.')
|
||||
return
|
||||
try:
|
||||
syncer.ScanAndDiff()
|
||||
syncer.PerformDeletions()
|
||||
syncer.PerformOverwrites()
|
||||
syncer.PerformCopies()
|
||||
finally:
|
||||
syncer.TimeReport()
|
||||
|
||||
if __name__ == '__main__':
|
||||
main(*sys.argv)
|
||||
|
|
@ -1,31 +1,9 @@
|
|||
[main]
|
||||
slaveType = linux-desktop
|
||||
repos = /Users/mozilla/awfy/repos
|
||||
tmpDir= /tmp/
|
||||
timeout = 20*60 ; in seconds
|
||||
serverURL = http://localhost:8000/
|
||||
|
||||
machine = 16
|
||||
updateURL = http://www.arewefastyet.com/???
|
||||
|
||||
[engines]
|
||||
list = mozilla
|
||||
|
||||
[benchmarks]
|
||||
browserList = benchmark.remote.octane,
|
||||
benchmark.remote.massive,
|
||||
benchmark.remote.jetstream,
|
||||
benchmark.remote.speedometer,
|
||||
benchmark.remote.kraken,
|
||||
benchmark.remote.sunspider,
|
||||
benchmark.remote.browsermark,
|
||||
benchmark.local.assorteddom
|
||||
shellList =
|
||||
|
||||
[mozilla]
|
||||
nightlyDir = http://archive.mozilla.org/pub/mozilla.org/firefox/tinderbox-builds/mozilla-inbound-linux64/
|
||||
pgoDir = http://archive.mozilla.org/pub/mozilla.org/firefox/tinderbox-builds/mozilla-inbound-linux-pgo/
|
||||
|
||||
[chrome]
|
||||
buildInfoUrl = http://build.chromium.org/p/chromium.lkgr/builders/Win
|
||||
nightlyDir = http://commondatastorage.googleapis.com/chromium-browser-continuous/Win/
|
||||
# Redirects will make it fail report the output
|
||||
# As a result it needs to be https, not http.
|
||||
updateURL = https://www.arewefastyet.com/???
|
||||
|
|
|
|||
|
|
@ -3,12 +3,13 @@ def getBenchmark(benchmark):
|
|||
section, name = benchmark.split(".")
|
||||
if section == "local":
|
||||
import benchmarks_local
|
||||
return benchmarks_local.getBenchmark(name);
|
||||
return benchmarks_local.getBenchmark(name)
|
||||
elif section == "remote":
|
||||
import benchmarks_remote
|
||||
return benchmarks_remote.getBenchmark(name);
|
||||
return benchmarks_remote.getBenchmark(name)
|
||||
elif section == "shell":
|
||||
import benchmarks_shell
|
||||
return benchmarks_shell.getBenchmark(name);
|
||||
return benchmarks_shell.getBenchmark(name)
|
||||
else:
|
||||
raise Exception("Unknown benchmark type")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,27 +1,32 @@
|
|||
import subprocess
|
||||
import socket
|
||||
import os
|
||||
import time
|
||||
import json
|
||||
import os
|
||||
import socket
|
||||
import subprocess
|
||||
import sys
|
||||
import time
|
||||
|
||||
sys.path.insert(1, '../driver')
|
||||
|
||||
import utils
|
||||
|
||||
class Benchmark:
|
||||
""" timeout is in minutes """
|
||||
def __init__(self, suite, version, timeout=2):
|
||||
self.suite = suite
|
||||
self.version = suite+" "+version
|
||||
def __init__(self, version, timeout=2, suite=None):
|
||||
self.suite = suite if suite is not None else self.name()
|
||||
self.version = self.suite + " " + version
|
||||
self.url = 'http://' + self.suite + ".localhost:8000"
|
||||
self.timeout = timeout
|
||||
|
||||
def processResults(self, results):
|
||||
return results
|
||||
|
||||
@staticmethod
|
||||
def name(self):
|
||||
raise Exception("NYI")
|
||||
|
||||
class Octane(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "octane", "2.0.1")
|
||||
Benchmark.__init__(self, "2.0.1")
|
||||
|
||||
def processResults(self, results):
|
||||
ret = []
|
||||
|
|
@ -32,9 +37,13 @@ class Octane(Benchmark):
|
|||
ret.append({'name': key, 'time': results[key]})
|
||||
return ret
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "octane"
|
||||
|
||||
class Dromaeo(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "dromaeo", "1.0", 17)
|
||||
Benchmark.__init__(self, "1.0", 17)
|
||||
self.url = 'http://' + self.suite + ".localhost:8000/?recommended"
|
||||
|
||||
def processResults(self, results):
|
||||
|
|
@ -46,9 +55,13 @@ class Dromaeo(Benchmark):
|
|||
ret.append({'name': key, 'time': results[key]})
|
||||
return ret
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "dromaeo"
|
||||
|
||||
class Massive(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "massive", "1.2", 9)
|
||||
Benchmark.__init__(self, "1.2", 9)
|
||||
|
||||
def processResults(self, results):
|
||||
ret = []
|
||||
|
|
@ -61,9 +74,13 @@ class Massive(Benchmark):
|
|||
ret.append({'name': item["benchmark"], 'time': item["result"]})
|
||||
return ret
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "massive"
|
||||
|
||||
class JetStream(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "jetstream", "1.0", 5)
|
||||
Benchmark.__init__(self, "1.0", 5)
|
||||
|
||||
def processResults(self, results):
|
||||
ret = []
|
||||
|
|
@ -74,13 +91,21 @@ class JetStream(Benchmark):
|
|||
ret.append({'name': item, 'time': results[item]["statistics"]["mean"]})
|
||||
return ret
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "jetstream"
|
||||
|
||||
class Speedometer(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "speedometer", "1.0", 4)
|
||||
Benchmark.__init__(self, "1.0", 4)
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "speedometer"
|
||||
|
||||
class Kraken(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "kraken", "1.1")
|
||||
Benchmark.__init__(self, "1.1")
|
||||
|
||||
def processResults(self, results):
|
||||
ret = []
|
||||
|
|
@ -100,9 +125,13 @@ class Kraken(Benchmark):
|
|||
ret.append({'name': "__total__", 'time': total })
|
||||
return ret
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "kraken"
|
||||
|
||||
class SunSpider(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "ss", "1.0.2", 1)
|
||||
Benchmark.__init__(self, "1.0.2", 1, suite="ss")
|
||||
self.url = "http://sunspider.localhost:8000/"
|
||||
|
||||
def processResults(self, results):
|
||||
|
|
@ -123,9 +152,13 @@ class SunSpider(Benchmark):
|
|||
ret.append({'name': "__total__", 'time': total })
|
||||
return ret
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "sunspider"
|
||||
|
||||
class Browsermark(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "browsermark", "2.1", 5)
|
||||
Benchmark.__init__(self, "2.1", 5)
|
||||
self.url = "http://browsermark.local:8082/"
|
||||
|
||||
def processResults(self, results):
|
||||
|
|
@ -137,27 +170,43 @@ class Browsermark(Benchmark):
|
|||
ret.append({'name': item[0], 'time': item[1]})
|
||||
return ret
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "browsermark"
|
||||
|
||||
class WasmMisc(Benchmark):
|
||||
def __init__(self):
|
||||
Benchmark.__init__(self, "0.2")
|
||||
self.url = "http://wasm.local:8000"
|
||||
|
||||
@staticmethod
|
||||
def name():
|
||||
return "wasm"
|
||||
|
||||
KnownBenchmarks = [
|
||||
Octane,
|
||||
Dromaeo,
|
||||
Massive,
|
||||
JetStream,
|
||||
Speedometer,
|
||||
Kraken,
|
||||
SunSpider,
|
||||
Browsermark,
|
||||
WasmMisc,
|
||||
]
|
||||
|
||||
# TODO use this when showing execute.py's help.
|
||||
def get_all_known_benchmark_names():
|
||||
return [b.name() for b in KnownBenchmarks]
|
||||
|
||||
def getBenchmark(name):
|
||||
if name == "octane":
|
||||
return Octane()
|
||||
if name == "dromaeo":
|
||||
return Dromaeo()
|
||||
if name == "massive":
|
||||
return Massive()
|
||||
if name == "jetstream":
|
||||
return JetStream()
|
||||
if name == "speedometer":
|
||||
return Speedometer()
|
||||
if name == "kraken":
|
||||
return Kraken()
|
||||
if name == "sunspider":
|
||||
return SunSpider()
|
||||
if name == "browsermark":
|
||||
return Browsermark()
|
||||
for b in KnownBenchmarks:
|
||||
if name == b.name():
|
||||
return b()
|
||||
raise Exception("Unknown benchmark")
|
||||
|
||||
# Test if server is running and start server if needed.
|
||||
s = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
|
||||
s = socket.socket(socket.AF_INET, socket.SOCK_STREAM)
|
||||
result = s.connect_ex(("localhost", 8000))
|
||||
s.close()
|
||||
if result > 0:
|
||||
|
|
|
|||
|
|
@ -16,44 +16,29 @@ class Benchmark(object):
|
|||
folder = folder[:-1]
|
||||
|
||||
self.suite = suite
|
||||
self.folder = folder
|
||||
self.folder_ = folder
|
||||
|
||||
with utils.chdir(os.path.join(utils.config.BenchmarkPath, self.folder)):
|
||||
with utils.chdir(os.path.join(utils.config.BenchmarkPath, self.folder_)):
|
||||
fp = open("VERSION", 'r')
|
||||
self.version = suite + " " + fp.read().strip("\r\n\r\n \t")
|
||||
fp.close()
|
||||
|
||||
def run(self, engine, submit):
|
||||
with utils.chdir(os.path.join(utils.config.BenchmarkPath, self.folder)):
|
||||
return self._run(engine, submit)
|
||||
|
||||
def _run(self, engine, submit):
|
||||
|
||||
for modInfo in engine.modes:
|
||||
try:
|
||||
tests = None
|
||||
print('Running ' + self.version + ' under ' + engine.shell() + ' ' + ' '.join(modInfo["args"]))
|
||||
tests = self.benchmark(engine.shell(), engine.env(), modInfo["args"])
|
||||
except Exception as e:
|
||||
print('Failed to run ' + self.version + '!')
|
||||
print("Exception: " + repr(e))
|
||||
pass
|
||||
if tests:
|
||||
submit.AddTests(tests, self.suite, self.version, modInfo["name"])
|
||||
def folder(self):
|
||||
return self.folder_
|
||||
|
||||
class Octane(Benchmark):
|
||||
def __init__(self):
|
||||
super(Octane, self).__init__('octane', 'octane/')
|
||||
|
||||
def benchmark(self, shell, env, args):
|
||||
def getCommand(self, shell, args):
|
||||
full_args = [shell]
|
||||
if args:
|
||||
full_args.extend(args)
|
||||
full_args.append('run.js')
|
||||
|
||||
print(os.getcwd())
|
||||
output = utils.RunTimedCheckOutput(full_args, env=env)
|
||||
return full_args
|
||||
|
||||
def processResults(self, output):
|
||||
tests = []
|
||||
lines = output.splitlines()
|
||||
|
||||
|
|
@ -75,17 +60,15 @@ class SunSpiderBased(Benchmark):
|
|||
super(SunSpiderBased, self).__init__(suite, folder)
|
||||
self.runs = runs
|
||||
|
||||
def benchmark(self, shell, env, args):
|
||||
def getCommand(self, shell, args):
|
||||
if args != None:
|
||||
args = '--args=' + ' '.join(args)
|
||||
else:
|
||||
args = ''
|
||||
|
||||
output = utils.RunTimedCheckOutput(["./sunspider",
|
||||
"--shell=" + shell,
|
||||
"--runs=" + str(self.runs),
|
||||
args],
|
||||
env=env)
|
||||
return ["sunspider", "--shell=" + shell, "--runs=" + str(self.runs), args]
|
||||
|
||||
def processResults(self, output):
|
||||
tests = []
|
||||
|
||||
lines = output.splitlines()
|
||||
|
|
@ -126,30 +109,11 @@ class AsmJSBased(Benchmark):
|
|||
def __init__(self, suite, folder):
|
||||
super(AsmJSBased, self).__init__(suite, folder)
|
||||
|
||||
"""
|
||||
def _run(self, submit, native, modes):
|
||||
# Run the C++ mode.
|
||||
full_args = [utils.config.PythonName, 'harness.py', '--native']
|
||||
full_args += ['--cc="' + native.cc + '"']
|
||||
full_args += ['--cxx="' + native.cxx + '"']
|
||||
full_args += ['--'] + native.args
|
||||
output = utils.RunTimedCheckOutput(full_args)
|
||||
def getCommand(self, shell, args):
|
||||
full_args = ['./harness.sh', shell + " " + " ".join(args)]
|
||||
return full_args
|
||||
|
||||
tests = self.parse(output)
|
||||
submit.AddTests(tests, self.suite, self.version, native.mode)
|
||||
|
||||
# Run normal benchmarks.
|
||||
super(AsmJS, self)._run(submit, native, modes)
|
||||
"""
|
||||
|
||||
def benchmark(self, shell, env, args):
|
||||
full_args = [utils.config.PythonName, 'harness.py', shell, '--'] + args
|
||||
print(' '.join(full_args))
|
||||
|
||||
output = utils.RunTimedCheckOutput(full_args, env=env)
|
||||
return self.parse(output)
|
||||
|
||||
def parse(self, output):
|
||||
def processResults(self, output):
|
||||
total = 0.0
|
||||
tests = []
|
||||
for line in output.splitlines():
|
||||
|
|
@ -175,15 +139,15 @@ class Dart(Benchmark):
|
|||
def __init__(self):
|
||||
super(Dart, self).__init__('dart', 'dart/')
|
||||
|
||||
def benchmark(self, shell, env, args):
|
||||
def getCommand(self, shell, args):
|
||||
full_args = [shell]
|
||||
if args:
|
||||
full_args.extend(args)
|
||||
full_args.append('run.js')
|
||||
|
||||
print(os.getcwd())
|
||||
output = utils.RunTimedCheckOutput(full_args, env=env)
|
||||
return full_args
|
||||
|
||||
def processResults(self, output):
|
||||
tests = []
|
||||
lines = output.splitlines()
|
||||
|
||||
|
|
@ -217,11 +181,3 @@ def getBenchmark(name):
|
|||
if name == "dart":
|
||||
return Dart()
|
||||
raise Exception("Unknown benchmark")
|
||||
|
||||
def run(submit, native, modes):
|
||||
for benchmark in Benchmarks:
|
||||
benchmark.run(submit, native, modes)
|
||||
submit.Finish(1)
|
||||
|
||||
if __name__ == "__main__":
|
||||
remote.takerpc()
|
||||
|
|
|
|||
144
slave/build.py
144
slave/build.py
|
|
@ -9,6 +9,8 @@ import socket
|
|||
import utils
|
||||
import puller
|
||||
import platform
|
||||
import subprocess
|
||||
import stat
|
||||
from utils import Run
|
||||
|
||||
import tarfile
|
||||
|
|
@ -47,27 +49,39 @@ class Builder(object):
|
|||
self.folder = folder
|
||||
|
||||
if platform.system() == "Darwin":
|
||||
#self.installClang()
|
||||
# assume clang has been upgraded using port or bootstrap mozilla
|
||||
self.env.add("CC", "clang")
|
||||
self.env.add("CXX", "clang++")
|
||||
self.env.add("LINK", "clang++")
|
||||
self.installClang()
|
||||
self.env.add("CC", os.path.abspath("clang-3.8.0/bin/clang"))
|
||||
self.env.add("CXX", os.path.abspath("clang-3.8.0/bin/clang++"))
|
||||
self.env.add("LINK", os.path.abspath("clang-3.8.0/bin/clang++"))
|
||||
|
||||
def installClang(self):
|
||||
# The standard clang version on mac is outdated.
|
||||
# Retrieve a better one.
|
||||
|
||||
if os.path.exists("clang-3.6.2"):
|
||||
if os.path.exists("clang-3.8.0"):
|
||||
return
|
||||
|
||||
urllib.urlretrieve("http://llvm.org/releases/3.6.2/clang+llvm-3.6.2-x86_64-apple-darwin.tar.xz", "./clang-3.6.2.tar.xz")
|
||||
tar = tarfile.open("clang-3.6.2.tar.xz", "r:xz")
|
||||
tar.extractall(".")
|
||||
tar.close()
|
||||
urllib.urlretrieve("http://llvm.org/releases/3.8.0/clang+llvm-3.8.0-x86_64-apple-darwin.tar.xz", "./clang-3.8.0.tar.xz")
|
||||
utils.run_realtime(["tar", "xf", "clang-3.8.0.tar.xz"])
|
||||
|
||||
shutil.move("clang+llvm-3.6.2-x86_64-apple-darwin", "clang-3.6.2")
|
||||
shutil.move("clang+llvm-3.8.0-x86_64-apple-darwin", "clang-3.8.0")
|
||||
|
||||
os.unlink("clang-3.6.2.tar.xz")
|
||||
os.unlink("clang-3.8.0.tar.xz")
|
||||
|
||||
def installNdk(self):
|
||||
# Retrieve the ndk needed to build an android app.
|
||||
# Using version 12, since that still supports gcc (Couldn't get clang working).
|
||||
assert platform.system() == "Linux"
|
||||
assert platform.architecture()[0] == "64bit"
|
||||
|
||||
with utils.FolderChanger(self.folder):
|
||||
if os.path.exists("android-ndk-r12"):
|
||||
print "already installed: ", os.path.join(self.folder, "android-ndk-r12")
|
||||
return
|
||||
|
||||
print "installing"
|
||||
urllib.urlretrieve("https://dl.google.com/android/repository/android-ndk-r12-linux-x86_64.zip", "./android-ndk.zip")
|
||||
Run(["unzip", "android-ndk.zip"])
|
||||
|
||||
def unlinkBinary(self):
|
||||
try:
|
||||
|
|
@ -90,7 +104,10 @@ class Builder(object):
|
|||
def build(self, puller):
|
||||
self.unlinkBinary()
|
||||
|
||||
self.make()
|
||||
try:
|
||||
self.make()
|
||||
except:
|
||||
pass
|
||||
|
||||
if not self.successfullyBuild():
|
||||
self.reconf()
|
||||
|
|
@ -100,7 +117,7 @@ class Builder(object):
|
|||
|
||||
info = self.retrieveInfo()
|
||||
info["revision"] = puller.identify()
|
||||
# Deafult 'shell' to True only if it isn't set yet!
|
||||
# Default 'shell' to True only if it isn't set yet!
|
||||
if 'shell' not in info:
|
||||
info["shell"] = True
|
||||
info["binary"] = os.path.abspath(self.binary())
|
||||
|
|
@ -121,6 +138,8 @@ class MozillaBuilder(Builder):
|
|||
def retrieveInfo(self):
|
||||
info = {}
|
||||
info["engine_type"] = "firefox"
|
||||
if self.config.startswith("android"):
|
||||
info["platform"] = "android"
|
||||
return info
|
||||
|
||||
def objdir(self):
|
||||
|
|
@ -130,50 +149,61 @@ class MozillaBuilder(Builder):
|
|||
return os.path.join(self.objdir(), 'dist', 'bin', 'js')
|
||||
|
||||
def reconf(self):
|
||||
# Step 0. install ndk if needed.
|
||||
if self.config.startswith("android"):
|
||||
self.env.remove("CC")
|
||||
self.env.remove("CXX")
|
||||
self.env.remove("LINK")
|
||||
self.installNdk()
|
||||
|
||||
# Step 1. autoconf.
|
||||
with utils.FolderChanger(os.path.join(self.folder, 'js', 'src')):
|
||||
if platform.system() == "Darwin":
|
||||
utils.Shell("autoconf213")
|
||||
utils.run_realtime("autoconf213", shell=True)
|
||||
elif platform.system() == "Linux":
|
||||
utils.Shell("autoconf2.13")
|
||||
utils.run_realtime("autoconf2.13", shell=True)
|
||||
elif platform.system() == "Windows":
|
||||
utils.Shell("autoconf-2.13")
|
||||
utils.run_realtime("autoconf-2.13", shell=True)
|
||||
|
||||
# Step 2. configure
|
||||
if os.path.exists(os.path.join(self.folder, 'js', 'src', 'Opt')):
|
||||
shutil.rmtree(os.path.join(self.folder, 'js', 'src', 'Opt'))
|
||||
os.mkdir(os.path.join(self.folder, 'js', 'src', 'Opt'))
|
||||
with utils.FolderChanger(os.path.join(self.folder, 'js', 'src', 'Opt')):
|
||||
args = ['--enable-optimize', '--disable-debug']
|
||||
if platform.architecture()[0] == "64bit" and self.config == "32bit":
|
||||
if platform.system() == "Darwin":
|
||||
args.append("--target=i686-apple-darwin10.0.0")
|
||||
elif platform.system() == "Linux":
|
||||
args.append("--target=i686-pc-linux-gnu")
|
||||
else:
|
||||
assert False
|
||||
args = ['--enable-optimize', '--disable-debug']
|
||||
if self.config == "android":
|
||||
args.append("--target=arm-linux-androideabi")
|
||||
args.append("--with-android-ndk="+os.path.abspath(self.folder)+"/android-ndk-r12/")
|
||||
args.append("--with-android-version=24")
|
||||
args.append("--enable-pie")
|
||||
if self.config == "android64":
|
||||
args.append("--target=aarch64-linux-androideabi")
|
||||
args.append("--with-android-ndk="+os.path.abspath(self.folder)+"/android-ndk-r12/")
|
||||
args.append("--with-android-version=24")
|
||||
args.append("--enable-pie")
|
||||
if platform.architecture()[0] == "64bit" and self.config == "32bit":
|
||||
if platform.system() == "Darwin":
|
||||
args.append("--target=i686-apple-darwin10.0.0")
|
||||
elif platform.system() == "Linux":
|
||||
args.append("--target=i686-pc-linux-gnu")
|
||||
else:
|
||||
assert False
|
||||
|
||||
Run(['../configure'] + args, self.env.get())
|
||||
with utils.FolderChanger(os.path.join(self.folder, 'js', 'src', 'Opt')):
|
||||
utils.Run(['../configure'] + args, self.env.get())
|
||||
return True
|
||||
|
||||
def make(self):
|
||||
if not os.path.exists(os.path.join(self.folder, 'js', 'src', 'Opt')):
|
||||
return
|
||||
utils.Shell("make -j6 -C " + os.path.join(self.folder, 'js', 'src', 'Opt'))
|
||||
utils.run_realtime("make -j6 -C " + os.path.join(self.folder, 'js', 'src', 'Opt'), shell=True)
|
||||
|
||||
class WebkitBuilder(Builder):
|
||||
def retrieveInfo(self):
|
||||
with utils.chdir(os.path.join(self.folder)):
|
||||
objdir = os.path.abspath(os.path.join('WebKitBuild', 'Release'))
|
||||
|
||||
info = {}
|
||||
info["engine_type"] = "webkit"
|
||||
info["env"] = {'DYLD_FRAMEWORK_PATH': objdir}
|
||||
return info
|
||||
|
||||
def patch(self):
|
||||
patch = os.path.join(os.path.dirname(os.path.realpath(__file__)), "jsc.patch")
|
||||
|
||||
with utils.FolderChanger(self.folder):
|
||||
# Hack 1: Remove reporting errors for warnings that currently are present.
|
||||
Run(["sed","-i.bac","s/GCC_TREAT_WARNINGS_AS_ERRORS = YES;/GCC_TREAT_WARNINGS_AS_ERRORS=NO;/","Source/JavaScriptCore/Configurations/Base.xcconfig"])
|
||||
|
|
@ -181,7 +211,6 @@ class WebkitBuilder(Builder):
|
|||
Run(["sed","-i.bac","s/GCC_TREAT_WARNINGS_AS_ERRORS = YES;/GCC_TREAT_WARNINGS_AS_ERRORS=NO;/","Source/WTF/Configurations/Base.xcconfig"])
|
||||
Run(["sed","-i.bac","s/std::numeric_limits<unsigned char>::max()/255/","Source/bmalloc/bmalloc/SmallLine.h"])
|
||||
Run(["sed","-i.bac","s/std::numeric_limits<unsigned char>::max()/255/","Source/bmalloc/bmalloc/SmallRun.h"])
|
||||
Run(["patch","Source/JavaScriptCore/jsc.cpp", patch])
|
||||
|
||||
# Hack 2: This check fails currently. Disable checking to still have a build.
|
||||
os.remove("Tools/Scripts/check-for-weak-vtables-and-externals")
|
||||
|
|
@ -195,7 +224,6 @@ class WebkitBuilder(Builder):
|
|||
Run(["svn","revert","Source/WTF/Configurations/Base.xcconfig"])
|
||||
Run(["svn","revert","Source/bmalloc/bmalloc/SmallLine.h"])
|
||||
Run(["svn","revert","Source/bmalloc/bmalloc/SmallPage.h"])
|
||||
Run(["svn","revert","Source/JavaScriptCore/jsc.cpp"])
|
||||
|
||||
def make(self):
|
||||
try:
|
||||
|
|
@ -207,6 +235,7 @@ class WebkitBuilder(Builder):
|
|||
Run(args, self.env.get())
|
||||
finally:
|
||||
self.clean()
|
||||
Run(["install_name_tool", "-change", "/System/Library/Frameworks/JavaScriptCore.framework/Versions/A/JavaScriptCore", self.objdir()+"/JavaScriptCore.framework/JavaScriptCore", self.objdir() + "/jsc"])
|
||||
|
||||
def objdir(self):
|
||||
return os.path.join(self.folder, 'WebKitBuild', 'Release')
|
||||
|
|
@ -218,19 +247,44 @@ class V8Builder(Builder):
|
|||
def __init__(self, config, folder):
|
||||
super(V8Builder, self).__init__(config, folder)
|
||||
|
||||
#self.env.add("GYP_DEFINES", "clang=1")
|
||||
self.env.add("PATH", os.path.join(self.folder, 'depot_tools')+":"+self.env.get()["PATH"])
|
||||
self.env.remove("CC")
|
||||
self.env.remove("CXX")
|
||||
self.env.remove("LINK")
|
||||
self.env.add("PATH", os.path.realpath(os.path.join(self.folder, 'depot_tools'))+":"+self.env.get()["PATH"])
|
||||
self.env.remove("CC")
|
||||
self.env.remove("CXX")
|
||||
self.env.remove("LINK")
|
||||
|
||||
if self.config.startswith("android"):
|
||||
if "target_os = ['android']" not in open(folder + '/.gclient').read():
|
||||
with open(folder + "/.gclient", "a") as myfile:
|
||||
myfile.write("target_os = ['android']")
|
||||
|
||||
def retrieveInfo(self):
|
||||
info = {}
|
||||
info["engine_type"] = "chrome"
|
||||
info["args"] = ['--expose-gc']
|
||||
if self.config == "android":
|
||||
info["platform"] = "android"
|
||||
return info
|
||||
|
||||
def make(self):
|
||||
if self.config == "android":
|
||||
objdir = os.path.realpath(self.objdir())
|
||||
if not os.path.isdir(objdir):
|
||||
os.mkdir(objdir)
|
||||
with utils.FolderChanger(os.path.join(self.folder, 'v8')):
|
||||
config = [
|
||||
'is_component_build = false',
|
||||
'is_debug = false',
|
||||
'symbol_level = 1',
|
||||
'target_cpu = "arm"',
|
||||
'target_os = "android"',
|
||||
'v8_android_log_stdout = true',
|
||||
'v8_test_isolation_mode = "prepare"',
|
||||
]
|
||||
args = 'gn gen '+objdir+' --args=\''+" ".join(config)+'\''
|
||||
Run(args, self.env.get(), shell=True)
|
||||
Run(["ninja", "-C", objdir], self.env.get())
|
||||
return
|
||||
|
||||
args = ['make', '-j6']
|
||||
if self.config == '32bit':
|
||||
args += ['ia32.release']
|
||||
|
|
@ -243,6 +297,8 @@ class V8Builder(Builder):
|
|||
Run(args, self.env.get())
|
||||
|
||||
def objdir(self):
|
||||
if self.config == 'android':
|
||||
return os.path.join(self.folder, 'v8', 'out', 'android_arm.release')
|
||||
if self.config == '64bit':
|
||||
return os.path.join(self.folder, 'v8', 'out', 'x64.release')
|
||||
elif self.config == '32bit':
|
||||
|
|
@ -302,7 +358,7 @@ if __name__ == "__main__":
|
|||
help="download to DIR, default=output/", metavar="DIR", default='output')
|
||||
|
||||
parser.add_option("-c", "--config", dest="config",
|
||||
help="default, 32bit, 64bit", default='default')
|
||||
help="auto, 32bit, 64bit, android, android64", default='auto')
|
||||
|
||||
parser.add_option("-f", "--force", dest="force", action="store_true", default=False,
|
||||
help="Force runs even without source changes")
|
||||
|
|
@ -316,11 +372,11 @@ if __name__ == "__main__":
|
|||
if not options.output.endswith("/"):
|
||||
options.output += "/"
|
||||
|
||||
if options.config not in ["default", "32bit", "64bit"]:
|
||||
if options.config not in ["auto", "32bit", "64bit", "android", "android64"]:
|
||||
print "Please provide a valid config"
|
||||
exit()
|
||||
|
||||
if options.config == "default":
|
||||
if options.config == "auto":
|
||||
options.config, _ = platform.architecture()
|
||||
|
||||
if options.config == "64bit" and platform.architecture()[0] == "32bit":
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ class Default(object):
|
|||
|
||||
def omit(self):
|
||||
return self.omit_
|
||||
|
||||
|
||||
def args(self):
|
||||
return self.args_
|
||||
|
||||
|
|
@ -45,6 +45,20 @@ class Default(object):
|
|||
# Currently only for firefox profile js file.
|
||||
return self.profile_
|
||||
|
||||
class Wasm(Default):
|
||||
def __init__(self, engine, shell):
|
||||
super(Wasm, self).__init__(engine, shell)
|
||||
if engine == "firefox":
|
||||
self.profile_ += "user_pref(\"javascript.options.wasm\", true);\n"
|
||||
elif engine == "chrome":
|
||||
self.args_ += ['--js-flags=--expose_wasm']
|
||||
|
||||
class WasmBaseline(Wasm):
|
||||
def __init__(self, engine, shell):
|
||||
super(WasmBaseline, self).__init__(engine, shell)
|
||||
if engine == "firefox":
|
||||
self.profile_ += "user_pref(\"javascript.options.wasm_baselinejit\", true);\n"
|
||||
|
||||
class UnboxedObjects(Default):
|
||||
def __init__(self, engine, shell):
|
||||
super(UnboxedObjects, self).__init__(engine, shell)
|
||||
|
|
@ -71,6 +85,23 @@ class TurboFan(Default):
|
|||
else:
|
||||
self.omit_ = True
|
||||
|
||||
class TurboIgnition(Default):
|
||||
def __init__(self, engine, shell):
|
||||
super(TurboIgnition, self).__init__(engine, shell)
|
||||
if engine == "chrome"and shell:
|
||||
self.args_.append("--turbo");
|
||||
self.args_.append("--ignition-staging");
|
||||
else:
|
||||
self.omit_ = True
|
||||
|
||||
class Ignition(Default):
|
||||
def __init__(self, engine, shell):
|
||||
super(Ignition, self).__init__(engine, shell)
|
||||
if engine == "chrome"and shell:
|
||||
self.args_.append("--ignition-staging");
|
||||
else:
|
||||
self.omit_ = True
|
||||
|
||||
class NoAsmjs(Default):
|
||||
def __init__(self, engine, shell):
|
||||
super(NoAsmjs, self).__init__(engine, shell)
|
||||
|
|
@ -130,12 +161,20 @@ class E10S(Default):
|
|||
def getConfig(name, info):
|
||||
if name == "default":
|
||||
return Default(info["engine_type"], info["shell"])
|
||||
if name == "wasm":
|
||||
return Wasm(info["engine_type"], info["shell"])
|
||||
if name == "wasm-baseline":
|
||||
return WasmBaseline(info["engine_type"], info["shell"])
|
||||
if name == "unboxedobjects":
|
||||
return UnboxedObjects(info["engine_type"], info["shell"])
|
||||
if name == "testbedregalloc":
|
||||
return TestbedRegalloc(info["engine_type"], info["shell"])
|
||||
if name == "turbofan":
|
||||
return TurboFan(info["engine_type"], info["shell"])
|
||||
if name == "ignition":
|
||||
return Ignition(info["engine_type"], info["shell"])
|
||||
if name == "turboignition":
|
||||
return TurboIgnition(info["engine_type"], info["shell"])
|
||||
if name == "noasmjs":
|
||||
return NoAsmjs(info["engine_type"], info["shell"])
|
||||
if name == "nonwritablejitcode":
|
||||
|
|
|
|||
|
|
@ -1,17 +1,19 @@
|
|||
import json
|
||||
import urllib2
|
||||
import urllib
|
||||
import re
|
||||
import os
|
||||
import platform
|
||||
import re
|
||||
import shutil
|
||||
import socket
|
||||
import utils
|
||||
import platform
|
||||
|
||||
import tarfile
|
||||
import urllib
|
||||
import urllib2
|
||||
import zipfile
|
||||
|
||||
socket.setdefaulttimeout(120)
|
||||
|
||||
import url_creator
|
||||
import utils
|
||||
|
||||
DEBUG = True
|
||||
|
||||
class DownloadTools(object):
|
||||
|
|
@ -27,35 +29,17 @@ class DownloadTools(object):
|
|||
return ArchiveMozillaDownloader(url)
|
||||
if url.startswith("http://commondatastorage.googleapis.com"):
|
||||
return GoogleAPISDownloader(url)
|
||||
if url.startswith("http://builds.nightly.webkit.org"):
|
||||
if (url.startswith("http://builds.nightly.webkit.org") or
|
||||
url.startswith("https://builds.nightly.webkit.org") or
|
||||
url.startswith("http://builds-nightly.webkit.org") or
|
||||
url.startswith("https://builds-nightly.webkit.org")):
|
||||
return BuildsWebkitDownloader(url)
|
||||
raise Exception("Unknown retriever")
|
||||
|
||||
@classmethod
|
||||
def getRevisionFinder(cls, repo):
|
||||
if "mozilla" in repo:
|
||||
return MozillaRevisionFinder(repo)
|
||||
if "chrome" in repo:
|
||||
return ChromeRevisionFinder(repo)
|
||||
if "webkit" in repo:
|
||||
return WebKitRevisionFinder(repo)
|
||||
raise Exception("Unknown repo")
|
||||
|
||||
@classmethod
|
||||
def forRepo(cls, repo, cset="latest"):
|
||||
revisionFinder = cls.getRevisionFinder(repo)
|
||||
return revisionFinder.find(cset)
|
||||
|
||||
class RevisionFinder(object):
|
||||
def __init__(self, repo):
|
||||
self.repo = repo
|
||||
|
||||
def find(self, cset):
|
||||
if cset == 'latest':
|
||||
urls = self.latest()[0:5]
|
||||
else:
|
||||
urls = self.urlForRevision(cset)
|
||||
|
||||
urlCreator = url_creator.getUrlCreator(repo)
|
||||
urls = urlCreator.find(cset)
|
||||
for url in urls:
|
||||
print "trying: " + url
|
||||
downloader = DownloadTools.forSpecificUrl(url)
|
||||
|
|
@ -63,134 +47,6 @@ class RevisionFinder(object):
|
|||
return downloader
|
||||
raise Exception("couldn't find the revision.")
|
||||
|
||||
class ChromeRevisionFinder(RevisionFinder):
|
||||
|
||||
def _url_base(self):
|
||||
platform = self._platform()
|
||||
return "http://commondatastorage.googleapis.com/chromium-browser-continuous/"+platform+"/"
|
||||
|
||||
def _platform(self):
|
||||
arch, _ = platform.architecture()
|
||||
arch = arch[0:2]
|
||||
if platform.system() == "Linux":
|
||||
return "Linux"
|
||||
if platform.system() == "Darwin":
|
||||
return "Mac"
|
||||
if platform.system() == "Windows" or platform.system().startswith("CYGWIN"):
|
||||
if arch == '32':
|
||||
return "Win"
|
||||
elif arch == '64':
|
||||
return "Win_x64"
|
||||
raise Exception("Unknown platform: " + platform.system())
|
||||
|
||||
def latest(self):
|
||||
response = urllib2.urlopen(self._url_base() + "LAST_CHANGE")
|
||||
chromium_rev = response.read()
|
||||
|
||||
response = urllib2.urlopen(self._url_base() + chromium_rev + "/REVISIONS")
|
||||
cset = re.findall('"v8_revision_git": "([a-z0-9]*)",', response.read())[0]
|
||||
|
||||
return [self._url_base() + chromium_rev + "/"]
|
||||
|
||||
class WebKitRevisionFinder(RevisionFinder):
|
||||
|
||||
def latest(self):
|
||||
response = urllib2.urlopen("http://nightly.webkit.org/")
|
||||
cset = re.findall('WebKit r([0-9]*)<', response.read())[0]
|
||||
|
||||
return ["http://builds.nightly.webkit.org/files/trunk/mac/WebKit-SVN-r" + cset + ".dmg"]
|
||||
|
||||
class MozillaRevisionFinder(RevisionFinder):
|
||||
|
||||
def __init__(self, repo):
|
||||
RevisionFinder.__init__(self, repo)
|
||||
self.url = self._url()
|
||||
if self.url[-1] != "/":
|
||||
self.url += "/"
|
||||
|
||||
def _platform(self):
|
||||
arch, _ = platform.architecture()
|
||||
arch = arch[0:2]
|
||||
if platform.system() == "Linux":
|
||||
return "linux"+arch
|
||||
if platform.system() == "Darwin":
|
||||
return "macosx64"
|
||||
if platform.system() == "Windows":
|
||||
return "win"+arch
|
||||
if platform.system().startswith("CYGWIN"):
|
||||
return "win"+arch
|
||||
raise Exception("Unknown platform: " + platform.system())
|
||||
|
||||
def _subdir(self):
|
||||
platform = self._platform()
|
||||
if self.repo == "mozilla-inbound":
|
||||
return "mozilla-inbound-"+platform
|
||||
if self.repo == "mozilla-central":
|
||||
return "mozilla-central-"+platform
|
||||
if self.repo == "mozilla-aurora":
|
||||
return "mozilla-aurora-"+platform
|
||||
if self.repo == "mozilla-beta":
|
||||
return "mozilla-beta-"+platform
|
||||
raise Exception("Unknown repo: " + self.repo)
|
||||
|
||||
def _url(self):
|
||||
return "http://archive.mozilla.org/pub/firefox/tinderbox-builds/"+self._subdir()+"/"
|
||||
|
||||
def _archive_url(self):
|
||||
return "http://inbound-archive.pub.build.mozilla.org/pub/mozilla.org/firefox/tinderbox-builds/"+self._subdir()+"/"
|
||||
|
||||
def treeherder_platform(self):
|
||||
platform = self._platform()
|
||||
if platform == "linux32":
|
||||
return platform
|
||||
if platform == "linux64":
|
||||
return platform
|
||||
if platform == "win32":
|
||||
return "windowsxp"
|
||||
if platform == "win64":
|
||||
return "windows8-64" # LATER??
|
||||
if platform == "macosx64":
|
||||
return "osx-10-7"
|
||||
|
||||
def latest(self):
|
||||
response = urllib2.urlopen(self.url+"?C=N;O=D")
|
||||
html = response.read()
|
||||
ids = list(set(re.findall("([0-9]{5,})/", html)))
|
||||
ids = sorted(ids, reverse=True)
|
||||
return [self.url + id for id in ids]
|
||||
|
||||
def _build_id(self, id):
|
||||
url = "https://treeherder.mozilla.org/api/project/"+self.repo+"/jobs/?count=2000&result_set_id="+str(id)+"&return_type=list"
|
||||
data = utils.fetch_json(url)
|
||||
builds = [i for i in data["results"] if i[1] == "buildbot"] # Builds
|
||||
builds = [i for i in builds if i[25] == "B" or i[25] == "Bo"] # Builds
|
||||
builds = [i for i in builds if i[13] == self.treeherder_platform()] # platform
|
||||
builds = [i for i in builds if i[5] == "opt"] # opt / debug / pgo
|
||||
|
||||
assert len(builds) == 1
|
||||
|
||||
url = "https://treeherder.mozilla.org/api/project/mozilla-inbound/job-log-url/?job_id="+str(builds[0][10])
|
||||
data = utils.fetch_json(url)
|
||||
return data[0]["url"].split("/")[-2]
|
||||
|
||||
def urlForRevision(self, cset):
|
||||
# here we use a detour using treeherder to find the build_id,
|
||||
# corresponding to a revision.
|
||||
url = "https://treeherder.mozilla.org/api/project/"+self.repo+"/resultset/?full=false&revision="+cset
|
||||
data = utils.fetch_json(url)
|
||||
|
||||
# No corresponding build found given revision
|
||||
if len(data["results"]) != 1:
|
||||
return None
|
||||
|
||||
# The revision is not pushed seperately. It is not the top commit
|
||||
# of a list of pushes that were done at the same time.
|
||||
if data["results"][0]["revision"] != cset:
|
||||
return None
|
||||
|
||||
build_id = self._build_id(data["results"][0]["id"])
|
||||
return [self._url()+str(build_id)+"/", self._archive_url()+str(build_id)+"/"]
|
||||
|
||||
class Downloader(object):
|
||||
|
||||
def __init__(self, url):
|
||||
|
|
@ -203,13 +59,13 @@ class Downloader(object):
|
|||
def valid(self):
|
||||
return self.getfilename() != None
|
||||
|
||||
def setOutputFolder(self, folder):
|
||||
def set_output_folder(self, folder):
|
||||
if not folder.endswith("/"):
|
||||
folder += "/"
|
||||
self.folder = folder
|
||||
|
||||
def download(self):
|
||||
self.createOutputFolder()
|
||||
self.create_output_folder()
|
||||
|
||||
filename = self.getfilename()
|
||||
assert filename
|
||||
|
|
@ -221,7 +77,7 @@ class Downloader(object):
|
|||
json.dump(info, fp)
|
||||
fp.close()
|
||||
|
||||
def createOutputFolder(self):
|
||||
def create_output_folder(self):
|
||||
if os.path.isdir(self.folder):
|
||||
shutil.rmtree(self.folder)
|
||||
os.makedirs(self.folder)
|
||||
|
|
@ -246,6 +102,7 @@ class Downloader(object):
|
|||
|
||||
class ArchiveMozillaDownloader(Downloader):
|
||||
|
||||
|
||||
def getfilename(self):
|
||||
try:
|
||||
response = urllib2.urlopen(self.url)
|
||||
|
|
@ -253,44 +110,18 @@ class ArchiveMozillaDownloader(Downloader):
|
|||
except:
|
||||
return None
|
||||
|
||||
possibles = re.findall(r'<a href=".*(firefox-[a-zA-Z0-9._-]*)">', html)
|
||||
possibles = [possible for possible in possibles if "tests" not in possible]
|
||||
possibles = [possible for possible in possibles if "checksum" not in possible]
|
||||
possibles = [possible for possible in possibles if ".json" not in possible]
|
||||
possibles = [possible for possible in possibles if "crashreporter" not in possible]
|
||||
possibles = [possible for possible in possibles if "langpack" not in possible]
|
||||
possibles = [possible for possible in possibles if ".txt" not in possible]
|
||||
possibles = [possible for possible in possibles if ".installer." not in possible]
|
||||
possibles = re.findall(r'<a href=".*((firefox|fennec)-[a-zA-Z0-9._-]*)">', html)
|
||||
possibles = [possible[0] for possible in possibles]
|
||||
|
||||
assert len(possibles) <= 1
|
||||
if len(possibles) == 0:
|
||||
return None
|
||||
return possibles[0]
|
||||
filename = self.getUniqueFileName(possibles)
|
||||
if filename:
|
||||
return filename
|
||||
|
||||
def getinfoname(self):
|
||||
response = urllib2.urlopen(self.url)
|
||||
html = response.read()
|
||||
filename = self.getPlatformFileName(possibles, platform.system(), platform.architecture()[0])
|
||||
if filename:
|
||||
return filename
|
||||
|
||||
possibles = re.findall(r'<a href=".*(firefox-[a-zA-Z0-9._-]*)">', html)
|
||||
possibles = [possible for possible in possibles if ".json" in possible]
|
||||
possibles = [possible for possible in possibles if "mozinfo" not in possible]
|
||||
possibles = [possible for possible in possibles if "test_packages" not in possible]
|
||||
|
||||
assert len(possibles) == 1
|
||||
return possibles[0]
|
||||
|
||||
def getbinary(self):
|
||||
if os.path.exists(self.folder + "firefox/firefox.exe"):
|
||||
return self.folder + "firefox/firefox.exe"
|
||||
if os.path.exists(self.folder + "firefox/firefox"):
|
||||
return self.folder + "firefox/firefox"
|
||||
files = os.listdir(self.folder)
|
||||
assert len(files) == 1
|
||||
if files[0].endswith(".apk"):
|
||||
return self.folder + files[0]
|
||||
if files[0].endswith(".dmg"):
|
||||
return self.folder + files[0]
|
||||
assert False
|
||||
return None
|
||||
|
||||
def retrieveInfo(self):
|
||||
infoname = self.getinfoname()
|
||||
|
|
@ -307,15 +138,92 @@ class ArchiveMozillaDownloader(Downloader):
|
|||
|
||||
return info
|
||||
|
||||
def _remove_extra_files(self, possibles):
|
||||
possibles = [possible for possible in possibles if "tests" not in possible]
|
||||
possibles = [possible for possible in possibles if "checksum" not in possible]
|
||||
possibles = [possible for possible in possibles if ".json" not in possible]
|
||||
possibles = [possible for possible in possibles if "crashreporter" not in possible]
|
||||
possibles = [possible for possible in possibles if "langpack" not in possible]
|
||||
possibles = [possible for possible in possibles if ".txt" not in possible]
|
||||
possibles = [possible for possible in possibles if ".installer." not in possible]
|
||||
|
||||
extensions = [".exe", ".tar.bz2",".dmg", ".zip", ".apk"]
|
||||
possibles2 = []
|
||||
for possible in possibles:
|
||||
endsWith = False;
|
||||
for ext in extensions:
|
||||
if possible.endswith(ext):
|
||||
endsWith = True
|
||||
break
|
||||
if endsWith:
|
||||
possibles2.append(possible)
|
||||
return possibles2
|
||||
|
||||
def getUniqueFileName(self, possibles):
|
||||
possibles = self._remove_extra_files(possibles)
|
||||
if len(possibles) != 1:
|
||||
return None
|
||||
return possibles[0]
|
||||
|
||||
def getPlatformFileName(self, possibles, platform, arch):
|
||||
possibles = self._remove_extra_files(possibles)
|
||||
if platform == "Darwin":
|
||||
possibles = [possible for possible in possibles if "mac" in possible]
|
||||
possibles = [possible for possible in possibles if possible.endswith(".dmg")]
|
||||
possibles = [possible for possible in possibles if "sdk" not in possible]
|
||||
elif platform == "Linux" and arch == "64bit":
|
||||
possibles = [possible for possible in possibles if "linux" in possible]
|
||||
possibles = [possible for possible in possibles if "x86_64" in possible]
|
||||
possibles = [possible for possible in possibles if "sdk" not in possible]
|
||||
elif platform == "Linux" and arch == "32bit":
|
||||
possibles = [possible for possible in possibles if "linux" in possible]
|
||||
possibles = [possible for possible in possibles if "i686" in possible]
|
||||
possibles = [possible for possible in possibles if "sdk" not in possible]
|
||||
elif platform == "Windows" and arch == "64bit":
|
||||
possibles = [possible for possible in possibles if "win64" in possible]
|
||||
elif platform == "Windows" and arch == "32bit":
|
||||
possibles = [possible for possible in possibles if "win32" in possible]
|
||||
|
||||
if len(possibles) != 1:
|
||||
return None
|
||||
return possibles[0]
|
||||
|
||||
def getinfoname(self):
|
||||
filename = self.getfilename()
|
||||
try:
|
||||
filename = os.path.splitext(filename)[0]
|
||||
response = urllib2.urlopen(self.url + filename + ".json")
|
||||
html = response.read()
|
||||
except:
|
||||
filename = os.path.splitext(filename)[0]
|
||||
response = urllib2.urlopen(self.url + filename + ".json")
|
||||
html = response.read()
|
||||
|
||||
return filename + ".json"
|
||||
|
||||
def getbinary(self):
|
||||
if os.path.exists(self.folder + "firefox/firefox.exe"):
|
||||
return self.folder + "firefox/firefox.exe"
|
||||
if os.path.exists(self.folder + "firefox/firefox"):
|
||||
return self.folder + "firefox/firefox"
|
||||
files = os.listdir(self.folder)
|
||||
assert len(files) == 1
|
||||
if files[0].endswith(".apk"):
|
||||
return self.folder + files[0]
|
||||
if files[0].endswith(".dmg"):
|
||||
return self.folder + files[0]
|
||||
assert False
|
||||
|
||||
|
||||
class GoogleAPISDownloader(Downloader):
|
||||
|
||||
def getfilename(self):
|
||||
platform = self.url.split("/")[-3]
|
||||
if platform == "Linux":
|
||||
if platform.startswith("Linux"):
|
||||
return "chrome-linux.zip"
|
||||
elif platform == "Mac":
|
||||
return "chrome-mac.zip"
|
||||
elif platform.startswith("Win"): # Yeah chrome puts win64 in win32 folder
|
||||
elif platform.startswith("Win"): # Chrome puts win64 in win32 folder.
|
||||
return "chrome-win32.zip"
|
||||
elif platform == "Android":
|
||||
return "chrome-android.zip"
|
||||
|
|
@ -378,9 +286,9 @@ if __name__ == "__main__":
|
|||
parser.add_option("-u", "--url", dest="url",
|
||||
help="Specify a specific url to download.", default=None)
|
||||
parser.add_option("--repo", dest="repo",
|
||||
help="Specify a repo to download. Currently only mozilla-inbound supported.", default=None)
|
||||
help="Specify a repo to download. Currently supports: mozilla-inbound, mozilla-central, mozilla-aurora, mozilla-beta, webkit, chrome", default=None)
|
||||
parser.add_option("-r", dest="cset",
|
||||
help="Specify the revision to download. Default to 'latest'", default='latest')
|
||||
help="Specify the revision to download. Defaults to 'latest'. (Note: this is currently only supported when using a mozilla repo)", default='latest')
|
||||
(options, args) = parser.parse_args()
|
||||
|
||||
if options.url:
|
||||
|
|
@ -388,7 +296,7 @@ if __name__ == "__main__":
|
|||
elif options.repo:
|
||||
downloader = DownloadTools.forRepo(options.repo, options.cset)
|
||||
else:
|
||||
raise Exception("You'll need to specify atleast an url or repo")
|
||||
raise Exception("You'll need to specify at least an url or repo")
|
||||
|
||||
downloader.setOutputFolder(options.output)
|
||||
downloader.set_output_folder(options.output)
|
||||
downloader.download()
|
||||
|
|
|
|||
|
|
@ -9,14 +9,15 @@ def getInfo(path):
|
|||
fp.close();
|
||||
|
||||
# which platform to execute:
|
||||
if info["binary"].endswith(".apk"):
|
||||
info["platform"] = "android"
|
||||
elif info["binary"].endswith(".dmg") or "mac" in info["binary"]:
|
||||
info["platform"] = "osx"
|
||||
elif info["binary"].endswith(".exe"):
|
||||
info["platform"] = "windows"
|
||||
else:
|
||||
info["platform"] = "linux"
|
||||
if "platform" not in info:
|
||||
if info["binary"].endswith(".apk"):
|
||||
info["platform"] = "android"
|
||||
elif info["binary"].endswith(".dmg") or "mac" in info["binary"]:
|
||||
info["platform"] = "osx"
|
||||
elif info["binary"].endswith(".exe"):
|
||||
info["platform"] = "windows"
|
||||
else:
|
||||
info["platform"] = "linux"
|
||||
|
||||
# default args and env
|
||||
if "args" not in info:
|
||||
|
|
|
|||
|
|
@ -1,18 +1,20 @@
|
|||
import benchmarks
|
||||
import configs
|
||||
import executors
|
||||
import engineInfo
|
||||
import submitter
|
||||
import json
|
||||
|
||||
import sys
|
||||
import utils
|
||||
import traceback
|
||||
|
||||
from optparse import OptionParser
|
||||
|
||||
import benchmarks
|
||||
import configs
|
||||
import engineInfo
|
||||
import executors
|
||||
import submitter
|
||||
import utils
|
||||
|
||||
parser = OptionParser(usage="usage: %prog url [options]")
|
||||
|
||||
parser.add_option("-b", "--benchmark", action="append", dest="benchmarks",
|
||||
help="Benchmark to run (the local ones are deprecated): remote.octane, remote.dromaeo, remote.massive, remote.jetstream, remote.speedometer, remote.kraken, remote.sunspider, remote.browsermark, shell.octane, shell.sunspider, shell.kraken, shell.assorted, shell.asmjsapps, shell.asmjsmicro, shell.shumway, shell.dart, local.octane, local.sunspider, local.kraken, local.weglsamples, local.assorteddom")
|
||||
help="Benchmark to run (the local ones are deprecated): remote.octane, remote.dromaeo, remote.massive, remote.jetstream, remote.speedometer, remote.kraken, remote.sunspider, remote.browsermark, remote.wasm, shell.octane, shell.sunspider, shell.kraken, shell.assorted, shell.asmjsapps, shell.asmjsmicro, shell.shumway, shell.dart, local.octane, local.sunspider, local.kraken, local.weglsamples, local.assorteddom")
|
||||
|
||||
parser.add_option("-s", "--submitter", dest="submitter", type="string", default="print",
|
||||
help="Submitter class ('remote' or 'print')")
|
||||
|
|
@ -57,6 +59,8 @@ if options.mode_rules is None:
|
|||
"firefox,noe10s:noe10s",
|
||||
"chrome,default:v8",
|
||||
"chrome,turbofan:v8-turbofan",
|
||||
"chrome,ignition:v8-ignition",
|
||||
"chrome,turboignition:v8-turbo-ignition",
|
||||
"webkit,default:jsc",
|
||||
"native,default:clang",
|
||||
"servo,default:servo"
|
||||
|
|
@ -93,13 +97,14 @@ for engine_path in options.engines:
|
|||
except Exception as e:
|
||||
print('Failed to get info about ' + engine_path + '!')
|
||||
print('Exception: ' + repr(e))
|
||||
traceback.print_exc(file=sys.stdout)
|
||||
|
||||
# Run every benchmark for every build and config
|
||||
benchmarks = [benchmarks.getBenchmark(i) for i in options.benchmarks]
|
||||
for benchmark in benchmarks:
|
||||
for engine_path in engines:
|
||||
info = engineInfo.getInfo(engine_path)
|
||||
executor = executors.getExecutor(info)
|
||||
executor = executors.getExecutor(info)
|
||||
|
||||
for config_name in options.configs:
|
||||
config = configs.getConfig(config_name, info)
|
||||
|
|
@ -113,6 +118,8 @@ for benchmark in benchmarks:
|
|||
except Exception as e:
|
||||
print('Failed to run ' + engine_path + ' - ' + benchmark.version + ' - ' + config_name + '!')
|
||||
print('Exception: ' + repr(e))
|
||||
import traceback
|
||||
traceback.print_exc()
|
||||
continue
|
||||
|
||||
mode = submitter.mode(info["engine_type"], config_name)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
import runners
|
||||
import time
|
||||
import os
|
||||
import sys
|
||||
import json
|
||||
|
||||
import utils
|
||||
import runners
|
||||
|
||||
class ShellExecutor(object):
|
||||
def __init__(self, engineInfo):
|
||||
|
|
@ -12,12 +12,32 @@ class ShellExecutor(object):
|
|||
|
||||
def run(self, benchmark, config):
|
||||
env = os.environ.copy()
|
||||
env.clear()
|
||||
env.update(config.env())
|
||||
env.update(self.engineInfo["env"])
|
||||
args = config.args() + self.engineInfo["args"]
|
||||
|
||||
with utils.chdir(os.path.join(utils.config.BenchmarkPath, benchmark.folder)):
|
||||
return benchmark.benchmark(self.engineInfo["binary"], env, args)
|
||||
args = config.args() + self.engineInfo["args"]
|
||||
benchmarkDir = os.path.join(utils.config.BenchmarkPath, benchmark.folder())
|
||||
|
||||
return self.execute(benchmarkDir, benchmark, args, env, config)
|
||||
|
||||
def execute(self, benchmarkDir, benchmark, args, env, config):
|
||||
runner = runners.getRunner(self.engineInfo["platform"])
|
||||
|
||||
# 1. Move all files to the device if needed
|
||||
benchmarkDir = runner.put(benchmarkDir)
|
||||
|
||||
# 2. Put the executables.
|
||||
path = os.path.dirname(self.engineInfo["binary"])
|
||||
path = runner.put(path, recursive = False)
|
||||
binary = os.path.join(path, os.path.basename(self.engineInfo["binary"]))
|
||||
|
||||
# 3. Execute
|
||||
env["LD_LIBRARY_PATH"] = path
|
||||
command = benchmark.getCommand(binary, args)
|
||||
output = runner.execute(command, env, benchmarkDir)
|
||||
|
||||
return benchmark.processResults(output)
|
||||
|
||||
class BrowserExecutor(object):
|
||||
|
||||
|
|
@ -110,7 +130,7 @@ class FirefoxExecutor(BrowserExecutor):
|
|||
self.resetResults()
|
||||
|
||||
# start browser
|
||||
process = runner.start(binary, args + ["--profile", runner.getdir("profile")], env)
|
||||
process = runner.start(binary, args + ["--no-remote", "--profile", runner.getdir("profile")], env)
|
||||
|
||||
# wait for results
|
||||
self.waitForResults(benchmark.timeout)
|
||||
|
|
@ -168,8 +188,8 @@ class WebKitExecutor(BrowserExecutor):
|
|||
# kill all possible running instances.
|
||||
runner.killAllInstances()
|
||||
|
||||
# remove the saved tabs.
|
||||
runner.rm(os.path.join(os.environ.get("HOME"), "Library","Saved Application State","com.apple.Safari.savedState"))
|
||||
# remove the saved tabs.
|
||||
runner.rm(os.path.join(os.environ.get("HOME"), "Library","Saved Application State","com.apple.Safari.savedState"))
|
||||
|
||||
# if needed install the executable
|
||||
binary = runner.install(self.engineInfo["binary"])
|
||||
|
|
@ -215,13 +235,13 @@ class ServoExecutor(BrowserExecutor):
|
|||
def getExecutor(engineInfo):
|
||||
if engineInfo["shell"]:
|
||||
return ShellExecutor(engineInfo)
|
||||
if engineInfo["engine_type"] == "firefox" and not engineInfo["shell"]:
|
||||
if engineInfo["engine_type"] == "firefox":
|
||||
return FirefoxExecutor(engineInfo)
|
||||
if engineInfo["engine_type"] == "chrome" and not engineInfo["shell"]:
|
||||
if engineInfo["engine_type"] == "chrome":
|
||||
return ChromeExecutor(engineInfo)
|
||||
if engineInfo["engine_type"] == "webkit" and not engineInfo["shell"]:
|
||||
if engineInfo["engine_type"] == "webkit":
|
||||
return WebKitExecutor(engineInfo)
|
||||
if engineInfo["engine_type"] == "edge" and not engineInfo["shell"]:
|
||||
if engineInfo["engine_type"] == "edge":
|
||||
return EdgeExecutor(engineInfo)
|
||||
if engineInfo["engine_type"] == "servo":
|
||||
return ServoExecutor(engineInfo)
|
||||
|
|
|
|||
|
|
@ -1,56 +0,0 @@
|
|||
Index: jsc.cpp
|
||||
===================================================================
|
||||
--- jsc.cpp (revision 177145)
|
||||
+++ jsc.cpp (working copy)
|
||||
@@ -34,6 +34,7 @@
|
||||
#include "Interpreter.h"
|
||||
#include "JSArray.h"
|
||||
#include "JSArrayBuffer.h"
|
||||
+#include "JSArrayBufferConstructor.h"
|
||||
#include "JSCInlines.h"
|
||||
#include "JSFunction.h"
|
||||
#include "JSLock.h"
|
||||
@@ -461,6 +462,7 @@
|
||||
static EncodedJSValue JSC_HOST_CALL functionRun(ExecState*);
|
||||
static EncodedJSValue JSC_HOST_CALL functionLoad(ExecState*);
|
||||
static EncodedJSValue JSC_HOST_CALL functionReadFile(ExecState*);
|
||||
+static EncodedJSValue JSC_HOST_CALL functionReadBinaryFile(ExecState*);
|
||||
static EncodedJSValue JSC_HOST_CALL functionCheckSyntax(ExecState*);
|
||||
static EncodedJSValue JSC_HOST_CALL functionReadline(ExecState*);
|
||||
static EncodedJSValue JSC_HOST_CALL functionPreciseTime(ExecState*);
|
||||
@@ -598,6 +600,7 @@
|
||||
addFunction(vm, "run", functionRun, 1);
|
||||
addFunction(vm, "load", functionLoad, 1);
|
||||
addFunction(vm, "readFile", functionReadFile, 1);
|
||||
+ addFunction(vm, "readBinaryFile", functionReadBinaryFile, 1);
|
||||
addFunction(vm, "checkSyntax", functionCheckSyntax, 1);
|
||||
addFunction(vm, "jscStack", functionJSCStack, 1);
|
||||
addFunction(vm, "readline", functionReadline, 0);
|
||||
@@ -929,6 +932,26 @@
|
||||
return JSValue::encode(jsString(exec, stringFromUTF(script.data())));
|
||||
}
|
||||
|
||||
+EncodedJSValue JSC_HOST_CALL functionReadBinaryFile(ExecState* exec)
|
||||
+{
|
||||
+ String fileName = exec->argument(0).toString(exec)->value(exec);
|
||||
+ Vector<char> script;
|
||||
+ if (!fillBufferWithContentsOfFile(fileName, script))
|
||||
+ return JSValue::encode(exec->vm().throwException(exec, createError(exec, ASCIILiteral("Could not open file."))));
|
||||
+
|
||||
+ JSArrayBufferConstructor* constructor =
|
||||
+ jsCast<JSArrayBufferConstructor*>(exec->callee());
|
||||
+
|
||||
+ RefPtr<ArrayBuffer> buffer = ArrayBuffer::create(script.data(), script.size());
|
||||
+ if (!buffer)
|
||||
+ return JSValue::encode(exec->vm().throwException(exec, createError(exec, ASCIILiteral("Out of memory"))));
|
||||
+
|
||||
+ JSArrayBuffer* result = JSArrayBuffer::create(
|
||||
+ exec->vm(), constructor->globalObject()->arrayBufferStructure(), buffer);
|
||||
+
|
||||
+ return JSValue::encode(result);
|
||||
+}
|
||||
+
|
||||
EncodedJSValue JSC_HOST_CALL functionCheckSyntax(ExecState* exec)
|
||||
{
|
||||
String fileName = exec->argument(0).toString(exec)->value(exec);
|
||||
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,252 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if 0; # not running under some shell
|
||||
|
||||
use strict;
|
||||
use Module::Build 0.25;
|
||||
use Getopt::Long;
|
||||
|
||||
my %opt_defs = (
|
||||
module => {type => '=s',
|
||||
desc => 'The name of the module to configure (required)'},
|
||||
feature => {type => ':s',
|
||||
desc => 'Print the value of a feature or all features'},
|
||||
config => {type => ':s',
|
||||
desc => 'Print the value of a config option'},
|
||||
set_feature => {type => '=s%',
|
||||
desc => "Set a feature to 'true' or 'false'"},
|
||||
set_config => {type => '=s%',
|
||||
desc => 'Set a config option to the given value'},
|
||||
eval => {type => '',
|
||||
desc => 'eval() config values before setting'},
|
||||
help => {type => '',
|
||||
desc => 'Print a help message and exit'},
|
||||
);
|
||||
|
||||
my %opts;
|
||||
GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs);
|
||||
print usage(%opt_defs) and exit(0)
|
||||
if $opts{help};
|
||||
|
||||
my @exclusive = qw(feature config set_feature set_config);
|
||||
die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs)
|
||||
unless grep(exists $opts{$_}, @exclusive) == 1;
|
||||
|
||||
die "Option --module is required\n" . usage(%opt_defs)
|
||||
unless $opts{module};
|
||||
|
||||
my $cf = load_config($opts{module});
|
||||
|
||||
if (exists $opts{feature}) {
|
||||
|
||||
if (length $opts{feature}) {
|
||||
print $cf->feature($opts{feature});
|
||||
} else {
|
||||
my %auto;
|
||||
# note: need to support older ConfigData.pm's
|
||||
@auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names");
|
||||
|
||||
print " Features defined in $cf:\n";
|
||||
foreach my $name (sort $cf->feature_names) {
|
||||
print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n";
|
||||
}
|
||||
}
|
||||
|
||||
} elsif (exists $opts{config}) {
|
||||
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Terse = 1;
|
||||
|
||||
if (length $opts{config}) {
|
||||
print Data::Dumper::Dumper($cf->config($opts{config})), "\n";
|
||||
} else {
|
||||
print " Configuration defined in $cf:\n";
|
||||
foreach my $name (sort $cf->config_names) {
|
||||
print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n";
|
||||
}
|
||||
}
|
||||
|
||||
} elsif (exists $opts{set_feature}) {
|
||||
my %to_set = %{$opts{set_feature}};
|
||||
while (my ($k, $v) = each %to_set) {
|
||||
die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/;
|
||||
$cf->set_feature($k, 0+$v); # Cast to a number, not a string
|
||||
}
|
||||
$cf->write;
|
||||
print "Feature" . 's'x(keys(%to_set)>1) . " saved\n";
|
||||
|
||||
} elsif (exists $opts{set_config}) {
|
||||
|
||||
my %to_set = %{$opts{set_config}};
|
||||
while (my ($k, $v) = each %to_set) {
|
||||
if ($opts{eval}) {
|
||||
$v = eval($v);
|
||||
die $@ if $@;
|
||||
}
|
||||
$cf->set_config($k, $v);
|
||||
}
|
||||
$cf->write;
|
||||
print "Config value" . 's'x(keys(%to_set)>1) . " saved\n";
|
||||
}
|
||||
|
||||
sub load_config {
|
||||
my $mod = shift;
|
||||
|
||||
$mod =~ /^([\w:]+)$/
|
||||
or die "Invalid module name '$mod'";
|
||||
|
||||
my $cf = $mod . "::ConfigData";
|
||||
eval "require $cf";
|
||||
die $@ if $@;
|
||||
|
||||
return $cf;
|
||||
}
|
||||
|
||||
sub usage {
|
||||
my %defs = @_;
|
||||
|
||||
my $out = "\nUsage: $0 [options]\n\n Options include:\n";
|
||||
|
||||
foreach my $name (sort keys %defs) {
|
||||
$out .= " --$name";
|
||||
|
||||
for ($defs{$name}{type}) {
|
||||
/^=s$/ and $out .= " <string>";
|
||||
/^=s%$/ and $out .= " <string>=<value>";
|
||||
}
|
||||
|
||||
pad_line($out, 35);
|
||||
$out .= "$defs{$name}{desc}\n";
|
||||
}
|
||||
|
||||
$out .= <<EOF;
|
||||
|
||||
Examples:
|
||||
$0 --module Foo::Bar --feature bazzable
|
||||
$0 --module Foo::Bar --config magic_number
|
||||
$0 --module Foo::Bar --set_feature bazzable=1
|
||||
$0 --module Foo::Bar --set_config magic_number=42
|
||||
|
||||
EOF
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub pad_line { $_[0] .= ' ' x ($_[1] - length($_[0]) + rindex($_[0], "\n")) }
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
config_data - Query or change configuration of Perl modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Get config/feature values
|
||||
config_data --module Foo::Bar --feature bazzable
|
||||
config_data --module Foo::Bar --config magic_number
|
||||
|
||||
# Set config/feature values
|
||||
config_data --module Foo::Bar --set_feature bazzable=1
|
||||
config_data --module Foo::Bar --set_config magic_number=42
|
||||
|
||||
# Print a usage message
|
||||
config_data --help
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<config_data> tool provides a command-line interface to the
|
||||
configuration of Perl modules. By "configuration", we mean something
|
||||
akin to "user preferences" or "local settings". This is a
|
||||
formalization and abstraction of the systems that people like Andreas
|
||||
Koenig (C<CPAN::Config>), Jon Swartz (C<HTML::Mason::Config>), Andy
|
||||
Wardley (C<Template::Config>), and Larry Wall (perl's own Config.pm)
|
||||
have developed independently.
|
||||
|
||||
The configuration system employed here was developed in the context of
|
||||
C<Module::Build>. Under this system, configuration information for a
|
||||
module C<Foo>, for example, is stored in a module called
|
||||
C<Foo::ConfigData>) (I would have called it C<Foo::Config>, but that
|
||||
was taken by all those other systems mentioned in the previous
|
||||
paragraph...). These C<...::ConfigData> modules contain the
|
||||
configuration data, as well as publicly accessible methods for
|
||||
querying and setting (yes, actually re-writing) the configuration
|
||||
data. The C<config_data> script (whose docs you are currently
|
||||
reading) is merely a front-end for those methods. If you wish, you
|
||||
may create alternate front-ends.
|
||||
|
||||
The two types of data that may be stored are called C<config> values
|
||||
and C<feature> values. A C<config> value may be any perl scalar,
|
||||
including references to complex data structures. It must, however, be
|
||||
serializable using C<Data::Dumper>. A C<feature> is a boolean (1 or
|
||||
0) value.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
This script functions as a basic getter/setter wrapper around the
|
||||
configuration of a single module. On the command line, specify which
|
||||
module's configuration you're interested in, and pass options to get
|
||||
or set C<config> or C<feature> values. The following options are
|
||||
supported:
|
||||
|
||||
=over 4
|
||||
|
||||
=item module
|
||||
|
||||
Specifies the name of the module to configure (required).
|
||||
|
||||
=item feature
|
||||
|
||||
When passed the name of a C<feature>, shows its value. The value will
|
||||
be 1 if the feature is enabled, 0 if the feature is not enabled, or
|
||||
empty if the feature is unknown. When no feature name is supplied,
|
||||
the names and values of all known features will be shown.
|
||||
|
||||
=item config
|
||||
|
||||
When passed the name of a C<config> entry, shows its value. The value
|
||||
will be displayed using C<Data::Dumper> (or similar) as perl code.
|
||||
When no config name is supplied, the names and values of all known
|
||||
config entries will be shown.
|
||||
|
||||
=item set_feature
|
||||
|
||||
Sets the given C<feature> to the given boolean value. Specify the value
|
||||
as either 1 or 0.
|
||||
|
||||
=item set_config
|
||||
|
||||
Sets the given C<config> entry to the given value.
|
||||
|
||||
=item eval
|
||||
|
||||
If the C<--eval> option is used, the values in C<set_config> will be
|
||||
evaluated as perl code before being stored. This allows moderately
|
||||
complicated data structures to be stored. For really complicated
|
||||
structures, you probably shouldn't use this command-line interface,
|
||||
just use the Perl API instead.
|
||||
|
||||
=item help
|
||||
|
||||
Prints a help message, including a few examples, and exits.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Ken Williams, kwilliams@cpan.org
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1999, Ken Williams. All rights reserved.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Module::Build(3), perl(1).
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,491 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
|
||||
=head1 NAME
|
||||
|
||||
corelist - a commandline frontend to Module::CoreList
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See L<Module::CoreList> for one.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
corelist -v
|
||||
corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
|
||||
corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
|
||||
corelist [-r <PerlVersion>] ...
|
||||
corelist --feature <FeatureName> [<FeatureName>] ...
|
||||
corelist --diff PerlVersion PerlVersion
|
||||
corelist --upstream <ModuleName>
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over
|
||||
|
||||
=item -a
|
||||
|
||||
lists all versions of the given module (or the matching modules, in case you
|
||||
used a module regexp) in the perls Module::CoreList knows about.
|
||||
|
||||
corelist -a Unicode
|
||||
|
||||
Unicode was first released with perl v5.6.2
|
||||
v5.6.2 3.0.1
|
||||
v5.8.0 3.2.0
|
||||
v5.8.1 4.0.0
|
||||
v5.8.2 4.0.0
|
||||
v5.8.3 4.0.0
|
||||
v5.8.4 4.0.1
|
||||
v5.8.5 4.0.1
|
||||
v5.8.6 4.0.1
|
||||
v5.8.7 4.1.0
|
||||
v5.8.8 4.1.0
|
||||
v5.8.9 5.1.0
|
||||
v5.9.0 4.0.0
|
||||
v5.9.1 4.0.0
|
||||
v5.9.2 4.0.1
|
||||
v5.9.3 4.1.0
|
||||
v5.9.4 4.1.0
|
||||
v5.9.5 5.0.0
|
||||
v5.10.0 5.0.0
|
||||
v5.10.1 5.1.0
|
||||
v5.11.0 5.1.0
|
||||
v5.11.1 5.1.0
|
||||
v5.11.2 5.1.0
|
||||
v5.11.3 5.2.0
|
||||
v5.11.4 5.2.0
|
||||
v5.11.5 5.2.0
|
||||
v5.12.0 5.2.0
|
||||
v5.12.1 5.2.0
|
||||
v5.12.2 5.2.0
|
||||
v5.12.3 5.2.0
|
||||
v5.12.4 5.2.0
|
||||
v5.13.0 5.2.0
|
||||
v5.13.1 5.2.0
|
||||
v5.13.2 5.2.0
|
||||
v5.13.3 5.2.0
|
||||
v5.13.4 5.2.0
|
||||
v5.13.5 5.2.0
|
||||
v5.13.6 5.2.0
|
||||
v5.13.7 6.0.0
|
||||
v5.13.8 6.0.0
|
||||
v5.13.9 6.0.0
|
||||
v5.13.10 6.0.0
|
||||
v5.13.11 6.0.0
|
||||
v5.14.0 6.0.0
|
||||
v5.14.1 6.0.0
|
||||
v5.15.0 6.0.0
|
||||
|
||||
=item -d
|
||||
|
||||
finds the first perl version where a module has been released by
|
||||
date, and not by version number (as is the default).
|
||||
|
||||
=item --diff
|
||||
|
||||
Given two versions of perl, this prints a human-readable table of all module
|
||||
changes between the two. The output format may change in the future, and is
|
||||
meant for I<humans>, not programs. For programs, use the L<Module::CoreList>
|
||||
API.
|
||||
|
||||
=item -? or -help
|
||||
|
||||
help! help! help! to see more help, try --man.
|
||||
|
||||
=item -man
|
||||
|
||||
all of the help
|
||||
|
||||
=item -v
|
||||
|
||||
lists all of the perl release versions we got the CoreList for.
|
||||
|
||||
If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>),
|
||||
you get a list of all the modules and their respective versions.
|
||||
(If you have the C<version> module, you can also use new-style version numbers,
|
||||
like C<5.8.8>.)
|
||||
|
||||
In module filtering context, it can be used as Perl version filter.
|
||||
|
||||
=item -r
|
||||
|
||||
lists all of the perl releases and when they were released
|
||||
|
||||
If you pass a perl version you get the release date for that version only.
|
||||
|
||||
=item --feature, -f
|
||||
|
||||
lists the first version bundle of each named feature given
|
||||
|
||||
=item --upstream, -u
|
||||
|
||||
Shows if the given module is primarily maintained in perl core or on CPAN
|
||||
and bug tracker URL.
|
||||
|
||||
=back
|
||||
|
||||
As a special case, if you specify the module name C<Unicode>, you'll get
|
||||
the version number of the Unicode Character Database bundled with the
|
||||
requested perl versions.
|
||||
|
||||
=cut
|
||||
|
||||
use Module::CoreList;
|
||||
use Getopt::Long qw(:config no_ignore_case);
|
||||
use Pod::Usage;
|
||||
use strict;
|
||||
use warnings;
|
||||
use List::Util qw/maxstr/;
|
||||
|
||||
my %Opts;
|
||||
|
||||
GetOptions(
|
||||
\%Opts,
|
||||
qw[ help|?! man! r|release:s v|version:s a! d diff|D feature|f u|upstream ]
|
||||
);
|
||||
|
||||
pod2usage(1) if $Opts{help};
|
||||
pod2usage(-verbose=>2) if $Opts{man};
|
||||
|
||||
if(exists $Opts{r} ){
|
||||
if ( !$Opts{r} ) {
|
||||
print "\nModule::CoreList has release info for the following perl versions:\n";
|
||||
my $versions = { };
|
||||
my $max_ver_len = max_mod_len(\%Module::CoreList::released);
|
||||
for my $ver ( grep !/0[01]0$/, sort keys %Module::CoreList::released ) {
|
||||
printf "%-${max_ver_len}s %s\n", format_perl_version($ver), $Module::CoreList::released{$ver};
|
||||
}
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $num_r = numify_version( $Opts{r} );
|
||||
my $version_hash = Module::CoreList->find_version($num_r);
|
||||
|
||||
if( !$version_hash ) {
|
||||
print "\nModule::CoreList has no info on perl $Opts{r}\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
printf "Perl %s was released on %s\n\n", format_perl_version($num_r), $Module::CoreList::released{$num_r};
|
||||
exit 0;
|
||||
}
|
||||
|
||||
if(exists $Opts{v} ){
|
||||
if( !$Opts{v} ) {
|
||||
print "\nModule::CoreList has info on the following perl versions:\n";
|
||||
print format_perl_version($_)."\n" for grep !/0[01]0$/, sort keys %Module::CoreList::version;
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $num_v = numify_version( $Opts{v} );
|
||||
my $version_hash = Module::CoreList->find_version($num_v);
|
||||
|
||||
if( !$version_hash ) {
|
||||
print "\nModule::CoreList has no info on perl $Opts{v}\n\n";
|
||||
exit 1;
|
||||
}
|
||||
|
||||
if ( !@ARGV ) {
|
||||
print "\nThe following modules were in perl $Opts{v} CORE\n";
|
||||
my $max_mod_len = max_mod_len($version_hash);
|
||||
for my $mod ( sort keys %$version_hash ) {
|
||||
printf "%-${max_mod_len}s %s\n", $mod, $version_hash->{$mod} || "";
|
||||
}
|
||||
print "\n";
|
||||
exit 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($Opts{diff}) {
|
||||
if(@ARGV != 2) {
|
||||
die "\nprovide exactly two perl core versions to diff with --diff\n";
|
||||
}
|
||||
|
||||
my ($old_ver, $new_ver) = @ARGV;
|
||||
|
||||
my $old = numify_version($old_ver);
|
||||
my $new = numify_version($new_ver);
|
||||
|
||||
my %diff = Module::CoreList::changes_between($old, $new);
|
||||
|
||||
for my $lib (sort keys %diff) {
|
||||
my $diff = $diff{$lib};
|
||||
|
||||
my $was = ! exists $diff->{left} ? '(absent)'
|
||||
: ! defined $diff->{left} ? '(undef)'
|
||||
: $diff->{left};
|
||||
|
||||
my $now = ! exists $diff->{right} ? '(absent)'
|
||||
: ! defined $diff->{right} ? '(undef)'
|
||||
: $diff->{right};
|
||||
|
||||
printf "%-35s %10s %10s\n", $lib, $was, $now;
|
||||
}
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($Opts{feature}) {
|
||||
die "\n--feature is only available with perl v5.16.0 or greater\n"
|
||||
if $] < 5.016;
|
||||
|
||||
die "\nprovide at least one feature name to --feature\n"
|
||||
unless @ARGV;
|
||||
|
||||
no warnings 'once';
|
||||
require feature;
|
||||
|
||||
my %feature2version;
|
||||
my @bundles = map { $_->[0] }
|
||||
sort { $b->[1] <=> $a->[1] }
|
||||
map { [$_, numify_version($_)] }
|
||||
grep { not /[^0-9.]/ }
|
||||
keys %feature::feature_bundle;
|
||||
|
||||
for my $version (@bundles) {
|
||||
$feature2version{$_} = $version =~ /^\d\.\d+$/ ? "$version.0" : $version
|
||||
for @{ $feature::feature_bundle{$version} };
|
||||
}
|
||||
|
||||
# allow internal feature names, just in case someone gives us __SUB__
|
||||
# instead of current_sub.
|
||||
while (my ($name, $internal) = each %feature::feature) {
|
||||
$internal =~ s/^feature_//;
|
||||
$feature2version{$internal} = $feature2version{$name}
|
||||
if $feature2version{$name};
|
||||
}
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
for my $feature (@ARGV) {
|
||||
print "feature \"$feature\" ",
|
||||
exists $feature2version{$feature}
|
||||
? "was first released with the perl "
|
||||
. format_perl_version(numify_version($feature2version{$feature}))
|
||||
. " feature bundle\n"
|
||||
: "doesn't exist (or so I think)\n";
|
||||
}
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ( !@ARGV ) {
|
||||
pod2usage(0);
|
||||
}
|
||||
|
||||
while (@ARGV) {
|
||||
my ($mod, $ver);
|
||||
if ($ARGV[0] =~ /=/) {
|
||||
($mod, $ver) = split /=/, shift @ARGV;
|
||||
} else {
|
||||
$mod = shift @ARGV;
|
||||
$ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : "";
|
||||
}
|
||||
|
||||
if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex
|
||||
module_version($mod,$ver);
|
||||
} else {
|
||||
my $re;
|
||||
eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex
|
||||
if ($@) {
|
||||
# regex errors are usually like 'Quantifier follow nothing in regex; marked by ...'
|
||||
# then we drop text after ';' to shorten message
|
||||
my $errmsg = $@ =~ /(.*);/ ? $1 : $@;
|
||||
warn "\n$mod is a bad regex: $errmsg\n";
|
||||
next;
|
||||
}
|
||||
my @mod = Module::CoreList->find_modules($re);
|
||||
if (@mod) {
|
||||
module_version($_, $ver) for @mod;
|
||||
} else {
|
||||
$ver |= '';
|
||||
print "\n$mod $ver has no match in CORE (or so I think)\n";
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
exit();
|
||||
|
||||
sub module_version {
|
||||
my($mod,$ver) = @_;
|
||||
|
||||
if ( $Opts{v} ) {
|
||||
my $numeric_v = numify_version($Opts{v});
|
||||
my $version_hash = Module::CoreList->find_version($numeric_v);
|
||||
if ($version_hash) {
|
||||
print $mod, " ", $version_hash->{$mod} || 'undef', "\n";
|
||||
return;
|
||||
}
|
||||
else { die "Shouldn't happen" }
|
||||
}
|
||||
|
||||
my $ret = $Opts{d}
|
||||
? Module::CoreList->first_release_by_date(@_)
|
||||
: Module::CoreList->first_release(@_);
|
||||
my $msg = $mod;
|
||||
$msg .= " $ver" if $ver;
|
||||
|
||||
my $rem = $Opts{d}
|
||||
? Module::CoreList->removed_from_by_date($mod)
|
||||
: Module::CoreList->removed_from($mod);
|
||||
|
||||
my $when = maxstr(values %Module::CoreList::released);
|
||||
print "\n","Data for $when\n";
|
||||
|
||||
if( defined $ret ) {
|
||||
my $deprecated = Module::CoreList->deprecated_in($mod);
|
||||
$msg .= " was ";
|
||||
$msg .= "first " unless $ver;
|
||||
$msg .= "released with perl " . format_perl_version($ret);
|
||||
$msg .= ( $rem ? ',' : ' and' ) . " deprecated (will be CPAN-only) in " . format_perl_version($deprecated) if $deprecated;
|
||||
$msg .= " and removed from " . format_perl_version($rem) if $rem;
|
||||
} else {
|
||||
$msg .= " was not in CORE (or so I think)";
|
||||
}
|
||||
|
||||
print $msg,"\n";
|
||||
|
||||
if( defined $ret and exists $Opts{u} ) {
|
||||
my $upsream = $Module::CoreList::upstream{$mod};
|
||||
$upsream = 'undef' unless $upsream;
|
||||
print "upstream: $upsream\n";
|
||||
if ( $upsream ne 'blead' ) {
|
||||
my $bugtracker = $Module::CoreList::bug_tracker{$mod};
|
||||
$bugtracker = 'unknown' unless $bugtracker;
|
||||
print "bug tracker: $bugtracker\n";
|
||||
}
|
||||
}
|
||||
|
||||
if(defined $ret and exists $Opts{a} and $Opts{a}){
|
||||
display_a($mod);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub max_mod_len {
|
||||
my $versions = shift;
|
||||
my $max = 0;
|
||||
for my $mod (keys %$versions) {
|
||||
$max = max($max, length $mod);
|
||||
}
|
||||
|
||||
return $max;
|
||||
}
|
||||
|
||||
sub max {
|
||||
my($this, $that) = @_;
|
||||
return $this if $this > $that;
|
||||
return $that;
|
||||
}
|
||||
|
||||
sub display_a {
|
||||
my $mod = shift;
|
||||
|
||||
for my $v (grep !/0[01]0$/, sort keys %Module::CoreList::version ) {
|
||||
next unless exists $Module::CoreList::version{$v}{$mod};
|
||||
|
||||
my $mod_v = $Module::CoreList::version{$v}{$mod} || 'undef';
|
||||
printf " %-10s %-10s\n", format_perl_version($v), $mod_v;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
|
||||
|
||||
{
|
||||
my $have_version_pm;
|
||||
sub have_version_pm {
|
||||
return $have_version_pm if defined $have_version_pm;
|
||||
return $have_version_pm = eval { require version; 1 };
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub format_perl_version {
|
||||
my $v = shift;
|
||||
return $v if $v < 5.006 or !have_version_pm;
|
||||
return version->new($v)->normal;
|
||||
}
|
||||
|
||||
|
||||
sub numify_version {
|
||||
my $ver = shift;
|
||||
if ($ver =~ /\..+\./) {
|
||||
have_version_pm()
|
||||
or die "You need to install version.pm to use dotted version numbers\n";
|
||||
$ver = version->new($ver)->numify;
|
||||
}
|
||||
$ver += 0;
|
||||
return $ver;
|
||||
}
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
$ corelist File::Spec
|
||||
|
||||
File::Spec was first released with perl 5.005
|
||||
|
||||
$ corelist File::Spec 0.83
|
||||
|
||||
File::Spec 0.83 was released with perl 5.007003
|
||||
|
||||
$ corelist File::Spec 0.89
|
||||
|
||||
File::Spec 0.89 was not in CORE (or so I think)
|
||||
|
||||
$ corelist File::Spec::Aliens
|
||||
|
||||
File::Spec::Aliens was not in CORE (or so I think)
|
||||
|
||||
$ corelist /IPC::Open/
|
||||
|
||||
IPC::Open2 was first released with perl 5
|
||||
|
||||
IPC::Open3 was first released with perl 5
|
||||
|
||||
$ corelist /MANIFEST/i
|
||||
|
||||
ExtUtils::Manifest was first released with perl 5.001
|
||||
|
||||
$ corelist /Template/
|
||||
|
||||
/Template/ has no match in CORE (or so I think)
|
||||
|
||||
$ corelist -v 5.8.8 B
|
||||
|
||||
B 1.09_01
|
||||
|
||||
$ corelist -v 5.8.8 /^B::/
|
||||
|
||||
B::Asmdata 1.01
|
||||
B::Assembler 0.07
|
||||
B::Bblock 1.02_01
|
||||
B::Bytecode 1.01_01
|
||||
B::C 1.04_01
|
||||
B::CC 1.00_01
|
||||
B::Concise 0.66
|
||||
B::Debug 1.02_01
|
||||
B::Deparse 0.71
|
||||
B::Disassembler 1.05
|
||||
B::Lint 1.03
|
||||
B::O 1.00
|
||||
B::Showlex 1.02
|
||||
B::Stackobj 1.00
|
||||
B::Stash 1.00
|
||||
B::Terse 1.03_01
|
||||
B::Xref 1.01
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002-2007 by D.H. aka PodMaster
|
||||
|
||||
Currently maintained by the perl 5 porters E<lt>perl5-porters@perl.orgE<gt>.
|
||||
|
||||
This program is distributed under the same terms as perl itself.
|
||||
See http://perl.org/ or http://cpan.org/ for more info on that.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,324 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/local/bin/perl
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
use App::Cpan '1.60_02';
|
||||
$VERSION = '1.61';
|
||||
|
||||
my $rc = App::Cpan->run( @ARGV );
|
||||
|
||||
# will this work under Strawberry Perl?
|
||||
exit( $rc || 0 );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
cpan - easily interact with CPAN from the command line
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# with arguments and no switches, installs specified modules
|
||||
cpan module_name [ module_name ... ]
|
||||
|
||||
# with switches, installs modules with extra behavior
|
||||
cpan [-cfgimtTw] module_name [ module_name ... ]
|
||||
|
||||
# with just the dot, install from the distribution in the
|
||||
# current directory
|
||||
cpan .
|
||||
|
||||
# without arguments, starts CPAN.pm shell
|
||||
cpan
|
||||
|
||||
# force install modules (usually those that fail tests)
|
||||
cpan -f module_name [ module_name ... ]
|
||||
|
||||
# install modules but without testing them
|
||||
cpan -T module_name [ module_name ... ]
|
||||
|
||||
# dump the configuration
|
||||
cpan -J
|
||||
|
||||
# load a different configuration to install Module::Foo
|
||||
cpan -j some/other/file Module::Foo
|
||||
|
||||
# without arguments, but some switches
|
||||
cpan [-ahrvACDlLO]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This script provides a command interface (not a shell) to CPAN. At the
|
||||
moment it uses CPAN.pm to do the work, but it is not a one-shot command
|
||||
runner for CPAN.pm.
|
||||
|
||||
=head2 Options
|
||||
|
||||
=over 4
|
||||
|
||||
=item -a
|
||||
|
||||
Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
|
||||
|
||||
=item -A module [ module ... ]
|
||||
|
||||
Shows the primary maintainers for the specified modules.
|
||||
|
||||
=item -c module
|
||||
|
||||
Runs a `make clean` in the specified module's directories.
|
||||
|
||||
=item -C module [ module ... ]
|
||||
|
||||
Show the F<Changes> files for the specified modules
|
||||
|
||||
=item -D module [ module ... ]
|
||||
|
||||
Show the module details.
|
||||
|
||||
=item -f
|
||||
|
||||
Force the specified action, when it normally would have failed. Use this
|
||||
to install a module even if its tests fail. When you use this option,
|
||||
-i is not optional for installing a module when you need to force it:
|
||||
|
||||
% cpan -f -i Module::Foo
|
||||
|
||||
=item -F
|
||||
|
||||
Turn off CPAN.pm's attempts to lock anything. You should be careful with
|
||||
this since you might end up with multiple scripts trying to muck in the
|
||||
same directory. This isn't so much of a concern if you're loading a special
|
||||
config with C<-j>, and that config sets up its own work directories.
|
||||
|
||||
=item -g module [ module ... ]
|
||||
|
||||
Downloads to the current directory the latest distribution of the module.
|
||||
|
||||
=item -G module [ module ... ]
|
||||
|
||||
UNIMPLEMENTED
|
||||
|
||||
Download to the current directory the latest distribution of the
|
||||
modules, unpack each distribution, and create a git repository for each
|
||||
distribution.
|
||||
|
||||
If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
|
||||
distribution.
|
||||
|
||||
=item -h
|
||||
|
||||
Print a help message and exit. When you specify C<-h>, it ignores all
|
||||
of the other options and arguments.
|
||||
|
||||
=item -i
|
||||
|
||||
Install the specified modules.
|
||||
|
||||
=item -I
|
||||
|
||||
Load C<local::lib> (think like C<-I> for loading lib paths).
|
||||
|
||||
=item -j Config.pm
|
||||
|
||||
Load the file that has the CPAN configuration data. This should have the
|
||||
same format as the standard F<CPAN/Config.pm> file, which defines
|
||||
C<$CPAN::Config> as an anonymous hash.
|
||||
|
||||
=item -J
|
||||
|
||||
Dump the configuration in the same format that CPAN.pm uses. This is useful
|
||||
for checking the configuration as well as using the dump as a starting point
|
||||
for a new, custom configuration.
|
||||
|
||||
=item -l
|
||||
|
||||
List all installed modules with their versions
|
||||
|
||||
=item -L author [ author ... ]
|
||||
|
||||
List the modules by the specified authors.
|
||||
|
||||
=item -m
|
||||
|
||||
Make the specified modules.
|
||||
|
||||
=item -O
|
||||
|
||||
Show the out-of-date modules.
|
||||
|
||||
=item -p
|
||||
|
||||
Ping the configured mirrors
|
||||
|
||||
=item -P
|
||||
|
||||
Find the best mirrors you could be using (but doesn't configure them just yet)
|
||||
|
||||
=item -r
|
||||
|
||||
Recompiles dynamically loaded modules with CPAN::Shell->recompile.
|
||||
|
||||
=item -t
|
||||
|
||||
Run a `make test` on the specified modules.
|
||||
|
||||
=item -T
|
||||
|
||||
Do not test modules. Simply install them.
|
||||
|
||||
=item -u
|
||||
|
||||
Upgrade all installed modules. Blindly doing this can really break things,
|
||||
so keep a backup.
|
||||
|
||||
=item -v
|
||||
|
||||
Print the script version and CPAN.pm version then exit.
|
||||
|
||||
=item -V
|
||||
|
||||
Print detailed information about the cpan client.
|
||||
|
||||
=item -w
|
||||
|
||||
UNIMPLEMENTED
|
||||
|
||||
Turn on cpan warnings. This checks various things, like directory permissions,
|
||||
and tells you about problems you might have.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Examples
|
||||
|
||||
# print a help message
|
||||
cpan -h
|
||||
|
||||
# print the version numbers
|
||||
cpan -v
|
||||
|
||||
# create an autobundle
|
||||
cpan -a
|
||||
|
||||
# recompile modules
|
||||
cpan -r
|
||||
|
||||
# upgrade all installed modules
|
||||
cpan -u
|
||||
|
||||
# install modules ( sole -i is optional )
|
||||
cpan -i Netscape::Booksmarks Business::ISBN
|
||||
|
||||
# force install modules ( must use -i )
|
||||
cpan -fi CGI::Minimal URI
|
||||
|
||||
=head1 ENVIRONMENT VARIABLES
|
||||
|
||||
=over 4
|
||||
|
||||
There are several components in CPAN.pm that use environment variables.
|
||||
The build tools, L<ExtUtils::MakeMaker> and L<Module::Build> use some,
|
||||
while others matter to the levels above them. Some of these are specified
|
||||
by the Perl Toolchain Gang:
|
||||
|
||||
Lancaster Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>
|
||||
|
||||
Oslo Concensus: L<https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/oslo-consensus.md>
|
||||
|
||||
=over 4
|
||||
|
||||
=item CPAN_OPTS
|
||||
|
||||
C<cpan> splits this variable on whitespace and prepends that list to C<@ARGV>
|
||||
before it processes the command-line arguments. For instance, if you always
|
||||
want to use C<local:lib>, you can set C<CPAN_OPTS> to C<-I>.
|
||||
|
||||
=item CPANSCRIPT_LOGLEVEL
|
||||
|
||||
The log level to use, with either the embedded, minimal logger or
|
||||
L<Log::Log4perl> if it is installed. Possible values are the same as
|
||||
the C<Log::Log4perl> levels: C<TRACE>, C<DEBUG>, C<INFO>, C<WARN>,
|
||||
C<ERROR>, and C<FATAL>. The default is C<INFO>.
|
||||
|
||||
=item GIT_COMMAND
|
||||
|
||||
The path to the C<git> binary to use for the Git features. The default
|
||||
is C</usr/local/bin/git>.
|
||||
|
||||
=item NONINTERACTIVE_TESTING
|
||||
|
||||
Assume no one is paying attention and skips prompts for distributions
|
||||
that do that correctly. C<cpan(1)> sets this to C<1> unless it already
|
||||
has a value (even if that value is false).
|
||||
|
||||
=item PERL_MM_USE_DEFAULT
|
||||
|
||||
Use the default answer for a prompted questions. C<cpan(1)> sets this
|
||||
to C<1> unless it already has a value (even if that value is false).
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT VALUES
|
||||
|
||||
The script exits with zero if it thinks that everything worked, or a
|
||||
positive number if it thinks that something failed. Note, however, that
|
||||
in some cases it has to divine a failure by the output of things it does
|
||||
not control. For now, the exit codes are vague:
|
||||
|
||||
1 An unknown error
|
||||
|
||||
2 The was an external problem
|
||||
|
||||
4 There was an internal problem with the script
|
||||
|
||||
8 A module failed to install
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
* one shot configuration values from the command line
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
* none noted
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Most behaviour, including environment variables and configuration,
|
||||
comes directly from CPAN.pm.
|
||||
|
||||
=head1 SOURCE AVAILABILITY
|
||||
|
||||
This code is in Github in the CPAN.pm repository:
|
||||
|
||||
https://github.com/andk/cpanpm
|
||||
|
||||
The source used to be tracked separately in another GitHub repo,
|
||||
but the canonical source is now in the above repo.
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Japheth Cleaver added the bits to allow a forced install (-f).
|
||||
|
||||
Jim Brandt suggest and provided the initial implementation for the
|
||||
up-to-date and Changes features.
|
||||
|
||||
Adam Kennedy pointed out that exit() causes problems on Windows
|
||||
where this script ends up with a .bat extension
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
brian d foy, C<< <bdfoy@cpan.org> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2001-2014, brian d foy, All Rights Reserved.
|
||||
|
||||
You may redistribute this under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
Различия файлов скрыты, потому что одна или несколько строк слишком длинны
|
|
@ -0,0 +1,50 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
|
||||
=head1 NAME
|
||||
|
||||
dbilogstrip - filter to normalize DBI trace logs for diff'ing
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Read DBI trace file C<dbitrace.log> and write out a stripped version to C<dbitrace_stripped.log>
|
||||
|
||||
dbilogstrip dbitrace.log > dbitrace_stripped.log
|
||||
|
||||
Run C<yourscript.pl> twice, each with different sets of arguments, with
|
||||
DBI_TRACE enabled. Filter the output and trace through C<dbilogstrip> into a
|
||||
separate file for each run. Then compare using diff. (This example assumes
|
||||
you're using a standard shell.)
|
||||
|
||||
DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log
|
||||
DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log
|
||||
diff -u dbitrace1.log dbitrace2.log
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>.
|
||||
|
||||
Replaces any references to process id or thread id, like C<pid#6254> with C<pidN>.
|
||||
|
||||
So a DBI trace line like this:
|
||||
|
||||
-> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400
|
||||
|
||||
will look like this:
|
||||
|
||||
-> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
|
||||
while (<>) {
|
||||
# normalize hex addresses: 0xDEADHEAD => 0xN
|
||||
s/ \b 0x [0-9a-f]+ /0xN/gx;
|
||||
# normalize process and thread id number
|
||||
s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx;
|
||||
|
||||
} continue {
|
||||
print or die "-p destination: $!\n";
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,263 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
|
||||
use strict;
|
||||
|
||||
my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o);
|
||||
|
||||
use Data::Dumper;
|
||||
use DBI::ProfileData;
|
||||
use Getopt::Long;
|
||||
|
||||
# default options
|
||||
my $number = 10;
|
||||
my $sort = 'total';
|
||||
my $filename = 'dbi.prof';
|
||||
my $reverse = 0;
|
||||
my $case_sensitive = 0;
|
||||
my (%match, %exclude);
|
||||
|
||||
# get options from command line
|
||||
GetOptions(
|
||||
'version' => sub { die "dbiprof $VERSION\n" },
|
||||
'help' => sub { exit usage() },
|
||||
'number=i' => \$number,
|
||||
'sort=s' => \$sort,
|
||||
'dumpnodes!' => \my $dumpnodes,
|
||||
'reverse' => \$reverse,
|
||||
'match=s' => \%match,
|
||||
'exclude=s' => \%exclude,
|
||||
'case-sensitive' => \$case_sensitive,
|
||||
'delete!' => \my $opt_delete,
|
||||
) or exit usage();
|
||||
|
||||
sub usage {
|
||||
print <<EOS;
|
||||
dbiprof [options] [files]
|
||||
|
||||
Reads and merges DBI profile data from files and prints a summary.
|
||||
|
||||
files: defaults to $filename
|
||||
|
||||
options:
|
||||
|
||||
-number=N show top N, defaults to $number
|
||||
-sort=S sort by S, defaults to $sort
|
||||
-reverse reverse the sort
|
||||
-match=K=V for filtering, see docs
|
||||
-exclude=K=V for filtering, see docs
|
||||
-case_sensitive for -match and -exclude
|
||||
-delete rename files before reading then delete afterwards
|
||||
-version print version number and exit
|
||||
-help print this help
|
||||
|
||||
EOS
|
||||
return 1;
|
||||
}
|
||||
|
||||
# list of files defaults to dbi.prof
|
||||
my @files = @ARGV ? @ARGV : ('dbi.prof');
|
||||
|
||||
|
||||
# instantiate ProfileData object
|
||||
my $prof = eval {
|
||||
DBI::ProfileData->new(
|
||||
Files => \@files,
|
||||
DeleteFiles => $opt_delete,
|
||||
);
|
||||
};
|
||||
die "Unable to load profile data: $@\n" if $@;
|
||||
|
||||
if (%match) { # handle matches
|
||||
while (my ($key, $val) = each %match) {
|
||||
if ($val =~ m!^/(.+)/$!) {
|
||||
$val = $case_sensitive ? qr/$1/ : qr/$1/i;
|
||||
}
|
||||
$prof->match($key, $val, case_sensitive => $case_sensitive);
|
||||
}
|
||||
}
|
||||
|
||||
if (%exclude) { # handle excludes
|
||||
while (my ($key, $val) = each %exclude) {
|
||||
if ($val =~ m!^/(.+)/$!) {
|
||||
$val = $case_sensitive ? qr/$1/ : qr/$1/i;
|
||||
}
|
||||
$prof->exclude($key, $val, case_sensitive => $case_sensitive);
|
||||
}
|
||||
}
|
||||
|
||||
# sort the data
|
||||
$prof->sort(field => $sort, reverse => $reverse);
|
||||
|
||||
# all done, print it out
|
||||
if ($dumpnodes) {
|
||||
$Data::Dumper::Indent = 1;
|
||||
$Data::Dumper::Terse = 1;
|
||||
$Data::Dumper::Useqq = 1;
|
||||
$Data::Dumper::Deparse = 0;
|
||||
print Dumper($prof->nodes);
|
||||
}
|
||||
else {
|
||||
print $prof->report(number => $number);
|
||||
}
|
||||
exit 0;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
dbiprof - command-line client for DBI::ProfileData
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
See a report of the ten queries with the longest total runtime in the
|
||||
profile dump file F<prof1.out>:
|
||||
|
||||
dbiprof prof1.out
|
||||
|
||||
See the top 10 most frequently run queries in the profile file
|
||||
F<dbi.prof> (the default):
|
||||
|
||||
dbiprof --sort count
|
||||
|
||||
See the same report with 15 entries:
|
||||
|
||||
dbiprof --sort count --number 15
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This tool is a command-line client for the DBI::ProfileData. It
|
||||
allows you to analyze the profile data file produced by
|
||||
DBI::ProfileDumper and produce various useful reports.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
This program accepts the following options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item --number N
|
||||
|
||||
Produce this many items in the report. Defaults to 10. If set to
|
||||
"all" then all results are shown.
|
||||
|
||||
=item --sort field
|
||||
|
||||
Sort results by the given field. Sorting by multiple fields isn't currently
|
||||
supported (patches welcome). The available sort fields are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item total
|
||||
|
||||
Sorts by total time run time across all runs. This is the default
|
||||
sort.
|
||||
|
||||
=item longest
|
||||
|
||||
Sorts by the longest single run.
|
||||
|
||||
=item count
|
||||
|
||||
Sorts by total number of runs.
|
||||
|
||||
=item first
|
||||
|
||||
Sorts by the time taken in the first run.
|
||||
|
||||
=item shortest
|
||||
|
||||
Sorts by the shortest single run.
|
||||
|
||||
=item key1
|
||||
|
||||
Sorts by the value of the first element in the Path, which should be numeric.
|
||||
You can also sort by C<key2> and C<key3>.
|
||||
|
||||
=back
|
||||
|
||||
=item --reverse
|
||||
|
||||
Reverses the selected sort. For example, to see a report of the
|
||||
shortest overall time:
|
||||
|
||||
dbiprof --sort total --reverse
|
||||
|
||||
=item --match keyN=value
|
||||
|
||||
Consider only items where the specified key matches the given value.
|
||||
Keys are numbered from 1. For example, let's say you used a
|
||||
DBI::Profile Path of:
|
||||
|
||||
[ DBIprofile_Statement, DBIprofile_Methodname ]
|
||||
|
||||
And called dbiprof as in:
|
||||
|
||||
dbiprof --match key2=execute
|
||||
|
||||
Your report would only show execute queries, leaving out prepares,
|
||||
fetches, etc.
|
||||
|
||||
If the value given starts and ends with slashes (C</>) then it will be
|
||||
treated as a regular expression. For example, to only include SELECT
|
||||
queries where key1 is the statement:
|
||||
|
||||
dbiprof --match key1=/^SELECT/
|
||||
|
||||
By default the match expression is matched case-insensitively, but
|
||||
this can be changed with the --case-sensitive option.
|
||||
|
||||
=item --exclude keyN=value
|
||||
|
||||
Remove items for where the specified key matches the given value. For
|
||||
example, to exclude all prepare entries where key2 is the method name:
|
||||
|
||||
dbiprof --exclude key2=prepare
|
||||
|
||||
Like C<--match>, If the value given starts and ends with slashes
|
||||
(C</>) then it will be treated as a regular expression. For example,
|
||||
to exclude UPDATE queries where key1 is the statement:
|
||||
|
||||
dbiprof --match key1=/^UPDATE/
|
||||
|
||||
By default the exclude expression is matched case-insensitively, but
|
||||
this can be changed with the --case-sensitive option.
|
||||
|
||||
=item --case-sensitive
|
||||
|
||||
Using this option causes --match and --exclude to work
|
||||
case-sensitively. Defaults to off.
|
||||
|
||||
=item --delete
|
||||
|
||||
Sets the C<DeleteFiles> option to L<DBI::ProfileData> which causes the
|
||||
files to be deleted after reading. See L<DBI::ProfileData> for more details.
|
||||
|
||||
=item --dumpnodes
|
||||
|
||||
Print the list of nodes in the form of a perl data structure.
|
||||
Use the C<-sort> option if you want the list sorted.
|
||||
|
||||
=item --version
|
||||
|
||||
Print the dbiprof version number and exit.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Sam Tregar <sam@tregar.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (C) 2002 Sam Tregar
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl 5 itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DBI::ProfileDumper|DBI::ProfileDumper>,
|
||||
L<DBI::Profile|DBI::Profile>, L<DBI|DBI>.
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -0,0 +1,184 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
|
||||
use strict;
|
||||
|
||||
my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o);
|
||||
|
||||
my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test';
|
||||
$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//;
|
||||
|
||||
require DBI::ProxyServer;
|
||||
|
||||
# XXX these should probably be moved into DBI::ProxyServer
|
||||
delete $ENV{IFS};
|
||||
delete $ENV{CDPATH};
|
||||
delete $ENV{ENV};
|
||||
delete $ENV{BASH_ENV};
|
||||
|
||||
if ($arg_test) {
|
||||
require RPC::PlServer::Test;
|
||||
@DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI);
|
||||
}
|
||||
|
||||
DBI::ProxyServer::main(@ARGV);
|
||||
|
||||
exit(0);
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
dbiproxy - A proxy server for the DBD::Proxy driver
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
dbiproxy <options> --localport=<port>
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This tool is just a front end for the DBI::ProxyServer package. All it
|
||||
does is picking options from the command line and calling
|
||||
DBI::ProxyServer::main(). See L<DBI::ProxyServer> for details.
|
||||
|
||||
Available options include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<--chroot=dir>
|
||||
|
||||
(UNIX only) After doing a bind(), change root directory to the given
|
||||
directory by doing a chroot(). This is useful for security, but it
|
||||
restricts the environment a lot. For example, you need to load DBI
|
||||
drivers in the config file or you have to create hard links to Unix
|
||||
sockets, if your drivers are using them. For example, with MySQL, a
|
||||
config file might contain the following lines:
|
||||
|
||||
my $rootdir = '/var/dbiproxy';
|
||||
my $unixsockdir = '/tmp';
|
||||
my $unixsockfile = 'mysql.sock';
|
||||
foreach $dir ($rootdir, "$rootdir$unixsockdir") {
|
||||
mkdir 0755, $dir;
|
||||
}
|
||||
link("$unixsockdir/$unixsockfile",
|
||||
"$rootdir$unixsockdir/$unixsockfile");
|
||||
require DBD::mysql;
|
||||
|
||||
{
|
||||
'chroot' => $rootdir,
|
||||
...
|
||||
}
|
||||
|
||||
If you don't know chroot(), think of an FTP server where you can see a
|
||||
certain directory tree only after logging in. See also the --group and
|
||||
--user options.
|
||||
|
||||
=item B<--configfile=file>
|
||||
|
||||
Config files are assumed to return a single hash ref that overrides the
|
||||
arguments of the new method. However, command line arguments in turn take
|
||||
precedence over the config file. See the "CONFIGURATION FILE" section
|
||||
in the L<DBI::ProxyServer> documentation for details on the config file.
|
||||
|
||||
=item B<--debug>
|
||||
|
||||
Turn debugging mode on. Mainly this asserts that logging messages of
|
||||
level "debug" are created.
|
||||
|
||||
=item B<--facility=mode>
|
||||
|
||||
(UNIX only) Facility to use for L<Sys::Syslog>. The default is
|
||||
B<daemon>.
|
||||
|
||||
=item B<--group=gid>
|
||||
|
||||
After doing a bind(), change the real and effective GID to the given.
|
||||
This is useful, if you want your server to bind to a privileged port
|
||||
(<1024), but don't want the server to execute as root. See also
|
||||
the --user option.
|
||||
|
||||
GID's can be passed as group names or numeric values.
|
||||
|
||||
=item B<--localaddr=ip>
|
||||
|
||||
By default a daemon is listening to any IP number that a machine
|
||||
has. This attribute allows to restrict the server to the given
|
||||
IP number.
|
||||
|
||||
=item B<--localport=port>
|
||||
|
||||
This attribute sets the port on which the daemon is listening. It
|
||||
must be given somehow, as there's no default.
|
||||
|
||||
=item B<--logfile=file>
|
||||
|
||||
Be default logging messages will be written to the syslog (Unix) or
|
||||
to the event log (Windows NT). On other operating systems you need to
|
||||
specify a log file. The special value "STDERR" forces logging to
|
||||
stderr. See L<Net::Daemon::Log> for details.
|
||||
|
||||
=item B<--mode=modename>
|
||||
|
||||
The server can run in three different modes, depending on the environment.
|
||||
|
||||
If you are running Perl 5.005 and did compile it for threads, then the
|
||||
server will create a new thread for each connection. The thread will
|
||||
execute the server's Run() method and then terminate. This mode is the
|
||||
default, you can force it with "--mode=threads".
|
||||
|
||||
If threads are not available, but you have a working fork(), then the
|
||||
server will behave similar by creating a new process for each connection.
|
||||
This mode will be used automatically in the absence of threads or if
|
||||
you use the "--mode=fork" option.
|
||||
|
||||
Finally there's a single-connection mode: If the server has accepted a
|
||||
connection, he will enter the Run() method. No other connections are
|
||||
accepted until the Run() method returns (if the client disconnects).
|
||||
This operation mode is useful if you have neither threads nor fork(),
|
||||
for example on the Macintosh. For debugging purposes you can force this
|
||||
mode with "--mode=single".
|
||||
|
||||
=item B<--pidfile=file>
|
||||
|
||||
(UNIX only) If this option is present, a PID file will be created at the
|
||||
given location. Default is to not create a pidfile.
|
||||
|
||||
=item B<--user=uid>
|
||||
|
||||
After doing a bind(), change the real and effective UID to the given.
|
||||
This is useful, if you want your server to bind to a privileged port
|
||||
(<1024), but don't want the server to execute as root. See also
|
||||
the --group and the --chroot options.
|
||||
|
||||
UID's can be passed as group names or numeric values.
|
||||
|
||||
=item B<--version>
|
||||
|
||||
Suppresses startup of the server; instead the version string will
|
||||
be printed and the program exits immediately.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright (c) 1997 Jochen Wiedmann
|
||||
Am Eisteich 9
|
||||
72555 Metzingen
|
||||
Germany
|
||||
|
||||
Email: joe@ispsoft.de
|
||||
Phone: +49 7123 14881
|
||||
|
||||
The DBI::ProxyServer module is free software; you can redistribute it
|
||||
and/or modify it under the same terms as Perl itself. In particular
|
||||
permission is granted to Tim Bunce for distributing this as a part of
|
||||
the DBI.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DBI::ProxyServer>, L<DBD::Proxy>, L<DBI>
|
||||
|
||||
=cut
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,148 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!./perl
|
||||
use 5.008001;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Encode;
|
||||
use Getopt::Std;
|
||||
use Carp;
|
||||
use Encode::Guess;
|
||||
$Getopt::Std::STANDARD_HELP_VERSION = 1;
|
||||
|
||||
my %opt;
|
||||
getopts( "huSs:", \%opt );
|
||||
my @suspect_list;
|
||||
list_valid_suspects() and exit if $opt{S};
|
||||
@suspect_list = split /:,/, $opt{s} if $opt{s};
|
||||
HELP_MESSAGE() if $opt{h};
|
||||
HELP_MESSAGE() unless @ARGV;
|
||||
do_guess($_) for @ARGV;
|
||||
|
||||
sub read_file {
|
||||
my $filename = shift;
|
||||
local $/;
|
||||
open my $fh, '<:raw', $filename or croak "$filename:$!";
|
||||
my $content = <$fh>;
|
||||
close $fh;
|
||||
return $content;
|
||||
}
|
||||
|
||||
sub do_guess {
|
||||
my $filename = shift;
|
||||
my $data = read_file($filename);
|
||||
my $enc = guess_encoding( $data, @suspect_list );
|
||||
if ( !ref($enc) && $opt{u} ) {
|
||||
return 1;
|
||||
}
|
||||
print "$filename\t";
|
||||
if ( ref($enc) ) {
|
||||
print $enc->mime_name();
|
||||
}
|
||||
else {
|
||||
print "unknown";
|
||||
}
|
||||
print "\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub list_valid_suspects {
|
||||
print join( "\n", Encode->encodings(":all") );
|
||||
print "\n";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub HELP_MESSAGE {
|
||||
exec 'pod2usage', $0 or die "pod2usage: $!"
|
||||
}
|
||||
__END__
|
||||
=head1 NAME
|
||||
|
||||
encguess - guess character encodings of files
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: encguess,v 0.1 2015/02/05 10:34:19 dankogai Exp $
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
encguess [switches] filename...
|
||||
|
||||
=head2 SWITCHES
|
||||
|
||||
=over 2
|
||||
|
||||
=item -h
|
||||
|
||||
show this message and exit.
|
||||
|
||||
=item -s
|
||||
|
||||
specify a list of "suspect encoding types" to test,
|
||||
seperated by either C<:> or C<,>
|
||||
|
||||
=item -S
|
||||
|
||||
output a list of all acceptable encoding types that can be used with
|
||||
the -s param
|
||||
|
||||
=item -u
|
||||
|
||||
suppress display of unidentified types
|
||||
|
||||
=back
|
||||
|
||||
=head2 EXAMPLES:
|
||||
|
||||
=over 2
|
||||
|
||||
=item *
|
||||
|
||||
Guess encoding of a file named C<test.txt>, using only the default
|
||||
suspect types.
|
||||
|
||||
encguess test.txt
|
||||
|
||||
=item *
|
||||
|
||||
Guess the encoding type of a file named C<test.txt>, using the suspect
|
||||
types C<euc-jp,shiftjis,7bit-jis>.
|
||||
|
||||
encguess -s euc-jp,shiftjis,7bit-jis test.txt
|
||||
encguess -s euc-jp:shiftjis:7bit-jis test.txt
|
||||
|
||||
=item *
|
||||
|
||||
Guess the encoding type of several files, do not display results for
|
||||
unidentified files.
|
||||
|
||||
encguess -us euc-jp,shiftjis,7bit-jis test*.txt
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The encoding identification is done by checking one encoding type at a
|
||||
time until all but the right type are eliminated. The set of encoding
|
||||
types to try is defined by the -s parameter and defaults to ascii,
|
||||
utf8 and UTF-16/32 with BOM. This can be overridden by passing one or
|
||||
more encoding types via the -s parameter. If you need to pass in
|
||||
multiple suspect encoding types, use a quoted string with the a space
|
||||
separating each value.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Encode::Guess>, L<Encode::Detect>
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
Copyright 2015 Michael LaGrasta and Dan Kogai.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the the Artistic License (2.0). You may obtain a
|
||||
copy of the full license at:
|
||||
|
||||
L<http://www.perlfoundation.org/artistic_license_2_0>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,986 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
use strict;
|
||||
|
||||
use Config;
|
||||
use File::Path qw(mkpath);
|
||||
use Getopt::Std;
|
||||
|
||||
# Make sure read permissions for all are set:
|
||||
if (defined umask && (umask() & 0444)) {
|
||||
umask (umask() & ~0444);
|
||||
}
|
||||
|
||||
getopts('Dd:rlhaQe');
|
||||
use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
|
||||
die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
|
||||
my @inc_dirs = inc_dirs() if $opt_a;
|
||||
|
||||
my $Exit = 0;
|
||||
|
||||
my $Dest_dir = $opt_d || $Config{installsitearch};
|
||||
die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
|
||||
unless -d $Dest_dir;
|
||||
|
||||
my @isatype = qw(
|
||||
char uchar u_char
|
||||
short ushort u_short
|
||||
int uint u_int
|
||||
long ulong u_long
|
||||
FILE key_t caddr_t
|
||||
float double size_t
|
||||
);
|
||||
|
||||
my %isatype;
|
||||
@isatype{@isatype} = (1) x @isatype;
|
||||
my $inif = 0;
|
||||
my %Is_converted;
|
||||
my %bad_file = ();
|
||||
|
||||
@ARGV = ('-') unless @ARGV;
|
||||
|
||||
build_preamble_if_necessary();
|
||||
|
||||
sub reindent($) {
|
||||
my($text) = shift;
|
||||
$text =~ s/\n/\n /g;
|
||||
$text =~ s/ /\t/g;
|
||||
$text;
|
||||
}
|
||||
|
||||
my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
|
||||
my ($incl, $incl_type, $incl_quote, $next);
|
||||
while (defined (my $file = next_file())) {
|
||||
if (-l $file and -d $file) {
|
||||
link_if_possible($file) if ($opt_l);
|
||||
next;
|
||||
}
|
||||
|
||||
# Recover from header files with unbalanced cpp directives
|
||||
$t = '';
|
||||
$tab = 0;
|
||||
|
||||
# $eval_index goes into '#line' directives, to help locate syntax errors:
|
||||
$eval_index = 1;
|
||||
|
||||
if ($file eq '-') {
|
||||
open(IN, "-");
|
||||
open(OUT, ">-");
|
||||
} else {
|
||||
($outfile = $file) =~ s/\.h$/.ph/ || next;
|
||||
print "$file -> $outfile\n" unless $opt_Q;
|
||||
if ($file =~ m|^(.*)/|) {
|
||||
$dir = $1;
|
||||
mkpath "$Dest_dir/$dir";
|
||||
}
|
||||
|
||||
if ($opt_a) { # automagic mode: locate header file in @inc_dirs
|
||||
foreach (@inc_dirs) {
|
||||
chdir $_;
|
||||
last if -f $file;
|
||||
}
|
||||
}
|
||||
|
||||
open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
|
||||
open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
|
||||
}
|
||||
|
||||
print OUT
|
||||
"require '_h2ph_pre.ph';\n\n",
|
||||
"no warnings qw(redefine misc);\n\n";
|
||||
|
||||
while (defined (local $_ = next_line($file))) {
|
||||
if (s/^\s*\#\s*//) {
|
||||
if (s/^define\s+(\w+)//) {
|
||||
$name = $1;
|
||||
$new = '';
|
||||
s/\s+$//;
|
||||
s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
|
||||
if (s/^\(([\w,\s]*)\)//) {
|
||||
$args = $1;
|
||||
my $proto = '() ';
|
||||
if ($args ne '') {
|
||||
$proto = '';
|
||||
foreach my $arg (split(/,\s*/,$args)) {
|
||||
$arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
|
||||
$curargs{$arg} = 1;
|
||||
}
|
||||
$args =~ s/\b(\w)/\$$1/g;
|
||||
$args = "my($args) = \@_;\n$t ";
|
||||
}
|
||||
s/^\s+//;
|
||||
expr();
|
||||
$new =~ s/(["\\])/\\$1/g; #"]);
|
||||
EMIT($proto);
|
||||
} else {
|
||||
s/^\s+//;
|
||||
expr();
|
||||
|
||||
$new = 1 if $new eq '';
|
||||
|
||||
# Shunt around such directives as '#define FOO FOO':
|
||||
next if $new =~ /^\s*&\Q$name\E\s*\z/;
|
||||
|
||||
$new = reindent($new);
|
||||
$args = reindent($args);
|
||||
$new =~ s/(['\\])/\\$1/g; #']);
|
||||
|
||||
print OUT $t, 'eval ';
|
||||
if ($opt_h) {
|
||||
print OUT "\"\\n#line $eval_index $outfile\\n\" . ";
|
||||
$eval_index++;
|
||||
}
|
||||
print OUT "'sub $name () {$new;}' unless defined(&$name);\n";
|
||||
}
|
||||
} elsif (/^(include|import|include_next)\s*([<\"])(.*)[>\"]/) {
|
||||
$incl_type = $1;
|
||||
$incl_quote = $2;
|
||||
$incl = $3;
|
||||
if (($incl_type eq 'include_next') ||
|
||||
($opt_e && exists($bad_file{$incl}))) {
|
||||
$incl =~ s/\.h$/.ph/;
|
||||
print OUT ($t,
|
||||
"eval {\n");
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT ($t, "my(\@REM);\n");
|
||||
if ($incl_type eq 'include_next') {
|
||||
print OUT ($t,
|
||||
"my(\%INCD) = map { \$INC{\$_} => 1 } ",
|
||||
"(grep { \$_ eq \"$incl\" } ",
|
||||
"keys(\%INC));\n");
|
||||
print OUT ($t,
|
||||
"\@REM = map { \"\$_/$incl\" } ",
|
||||
"(grep { not exists(\$INCD{\"\$_/$incl\"})",
|
||||
" and -f \"\$_/$incl\" } \@INC);\n");
|
||||
} else {
|
||||
print OUT ($t,
|
||||
"\@REM = map { \"\$_/$incl\" } ",
|
||||
"(grep {-r \"\$_/$incl\" } \@INC);\n");
|
||||
}
|
||||
print OUT ($t,
|
||||
"require \"\$REM[0]\" if \@REM;\n");
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT ($t,
|
||||
"};\n");
|
||||
print OUT ($t,
|
||||
"warn(\$\@) if \$\@;\n");
|
||||
} else {
|
||||
$incl =~ s/\.h$/.ph/;
|
||||
# copy the prefix in the quote syntax (#include "x.h") case
|
||||
if ($incl !~ m|/| && $incl_quote eq q{"} && $file =~ m|^(.*)/|) {
|
||||
$incl = "$1/$incl";
|
||||
}
|
||||
print OUT $t,"require '$incl';\n";
|
||||
}
|
||||
} elsif (/^ifdef\s+(\w+)/) {
|
||||
print OUT $t,"if(defined(&$1)) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (/^ifndef\s+(\w+)/) {
|
||||
print OUT $t,"unless(defined(&$1)) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (s/^if\s+//) {
|
||||
$new = '';
|
||||
$inif = 1;
|
||||
expr();
|
||||
$inif = 0;
|
||||
print OUT $t,"if($new) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (s/^elif\s+//) {
|
||||
$new = '';
|
||||
$inif = 1;
|
||||
expr();
|
||||
$inif = 0;
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT $t,"}\n elsif($new) {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (/^else/) {
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT $t,"} else {\n";
|
||||
$tab += 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
} elsif (/^endif/) {
|
||||
$tab -= 4;
|
||||
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
|
||||
print OUT $t,"}\n";
|
||||
} elsif(/^undef\s+(\w+)/) {
|
||||
print OUT $t, "undef(&$1) if defined(&$1);\n";
|
||||
} elsif(/^error\s+(".*")/) {
|
||||
print OUT $t, "die($1);\n";
|
||||
} elsif(/^error\s+(.*)/) {
|
||||
print OUT $t, "die(\"", quotemeta($1), "\");\n";
|
||||
} elsif(/^warning\s+(.*)/) {
|
||||
print OUT $t, "warn(\"", quotemeta($1), "\");\n";
|
||||
} elsif(/^ident\s+(.*)/) {
|
||||
print OUT $t, "# $1\n";
|
||||
}
|
||||
} elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi
|
||||
until(/\{[^}]*\}.*;/ || /;/) {
|
||||
last unless defined ($next = next_line($file));
|
||||
chomp $next;
|
||||
# drop "#define FOO FOO" in enums
|
||||
$next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
|
||||
# #defines in enums (aliases)
|
||||
$next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
|
||||
$_ .= $next;
|
||||
print OUT "# $next\n" if $opt_D;
|
||||
}
|
||||
s/#\s*if.*?#\s*endif//g; # drop #ifdefs
|
||||
s@/\*.*?\*/@@g;
|
||||
s/\s+/ /g;
|
||||
next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
|
||||
(my $enum_subs = $3) =~ s/\s//g;
|
||||
my @enum_subs = split(/,/, $enum_subs);
|
||||
my $enum_val = -1;
|
||||
foreach my $enum (@enum_subs) {
|
||||
my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
|
||||
$enum_name or next;
|
||||
$enum_value =~ s/^=//;
|
||||
$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
|
||||
if ($opt_h) {
|
||||
print OUT ($t,
|
||||
"eval(\"\\n#line $eval_index $outfile\\n",
|
||||
"sub $enum_name () \{ $enum_val; \}\") ",
|
||||
"unless defined(\&$enum_name);\n");
|
||||
++ $eval_index;
|
||||
} else {
|
||||
print OUT ($t,
|
||||
"eval(\"sub $enum_name () \{ $enum_val; \}\") ",
|
||||
"unless defined(\&$enum_name);\n");
|
||||
}
|
||||
}
|
||||
} elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
|
||||
and !/;\s*$/ and !/{\s*}\s*$/)
|
||||
{ # { for vi
|
||||
# This is a hack to parse the inline functions in the glibc headers.
|
||||
# Warning: massive kludge ahead. We suppose inline functions
|
||||
# are mainly constructed like macros.
|
||||
while (1) {
|
||||
last unless defined ($next = next_line($file));
|
||||
chomp $next;
|
||||
undef $_, last if $next =~ /__THROW\s*;/
|
||||
or $next =~ /^(__extension__|extern|static)\b/;
|
||||
$_ .= " $next";
|
||||
print OUT "# $next\n" if $opt_D;
|
||||
last if $next =~ /^}|^{.*}\s*$/;
|
||||
}
|
||||
next if not defined; # because it's only a prototype
|
||||
s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
|
||||
# violently drop #ifdefs
|
||||
s/#\s*if.*?#\s*endif//g
|
||||
and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
|
||||
if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
|
||||
$name = $1;
|
||||
} else {
|
||||
warn "name not found"; next; # shouldn't occur...
|
||||
}
|
||||
my @args;
|
||||
if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
|
||||
for my $arg (split /,/, $1) {
|
||||
if ($arg =~ /(\w+)\s*$/) {
|
||||
$curargs{$1} = 1;
|
||||
push @args, $1;
|
||||
}
|
||||
}
|
||||
}
|
||||
$args = (
|
||||
@args
|
||||
? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t "
|
||||
: ""
|
||||
);
|
||||
my $proto = @args ? '' : '() ';
|
||||
$new = '';
|
||||
s/\breturn\b//g; # "return" doesn't occur in macros usually...
|
||||
expr();
|
||||
# try to find and perlify local C variables
|
||||
our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
|
||||
{
|
||||
use re "eval";
|
||||
my $typelist = join '|', keys %isatype;
|
||||
$new =~ s['
|
||||
(?:(?:__)?const(?:__)?\s+)?
|
||||
(?:(?:un)?signed\s+)?
|
||||
(?:long\s+)?
|
||||
(?:$typelist)\s+
|
||||
(\w+)
|
||||
(?{ push @local_variables, $1 })
|
||||
']
|
||||
[my \$$1]gx;
|
||||
$new =~ s['
|
||||
(?:(?:__)?const(?:__)?\s+)?
|
||||
(?:(?:un)?signed\s+)?
|
||||
(?:long\s+)?
|
||||
(?:$typelist)\s+
|
||||
' \s+ &(\w+) \s* ;
|
||||
(?{ push @local_variables, $1 })
|
||||
]
|
||||
[my \$$1;]gx;
|
||||
}
|
||||
$new =~ s/&$_\b/\$$_/g for @local_variables;
|
||||
$new =~ s/(["\\])/\\$1/g; #"]);
|
||||
# now that's almost like a macro (we hope)
|
||||
EMIT($proto);
|
||||
}
|
||||
}
|
||||
$Is_converted{$file} = 1;
|
||||
if ($opt_e && exists($bad_file{$file})) {
|
||||
unlink($Dest_dir . '/' . $outfile);
|
||||
$next = '';
|
||||
} else {
|
||||
print OUT "1;\n";
|
||||
queue_includes_from($file) if $opt_a;
|
||||
}
|
||||
}
|
||||
|
||||
if ($opt_e && (scalar(keys %bad_file) > 0)) {
|
||||
warn "Was unable to convert the following files:\n";
|
||||
warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
|
||||
}
|
||||
|
||||
exit $Exit;
|
||||
|
||||
sub EMIT {
|
||||
my $proto = shift;
|
||||
|
||||
$new = reindent($new);
|
||||
$args = reindent($args);
|
||||
if ($t ne '') {
|
||||
$new =~ s/(['\\])/\\$1/g; #']);
|
||||
if ($opt_h) {
|
||||
print OUT $t,
|
||||
"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
|
||||
$eval_index++;
|
||||
} else {
|
||||
print OUT $t,
|
||||
"eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
|
||||
}
|
||||
} else {
|
||||
print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
|
||||
}
|
||||
%curargs = ();
|
||||
return;
|
||||
}
|
||||
|
||||
sub expr {
|
||||
if (/\b__asm__\b/) { # freak out
|
||||
$new = '"(assembly code)"';
|
||||
return
|
||||
}
|
||||
my $joined_args;
|
||||
if(keys(%curargs)) {
|
||||
$joined_args = join('|', keys(%curargs));
|
||||
}
|
||||
while ($_ ne '') {
|
||||
s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
|
||||
s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
|
||||
s/^(\s+)// && do {$new .= ' '; next;};
|
||||
s/^0X([0-9A-F]+)[UL]*//i
|
||||
&& do {my $hex = $1;
|
||||
$hex =~ s/^0+//;
|
||||
if (length $hex > 8 && !$Config{use64bitint}) {
|
||||
# Croak if nv_preserves_uv_bits < 64 ?
|
||||
$new .= hex(substr($hex, -8)) +
|
||||
2**32 * hex(substr($hex, 0, -8));
|
||||
# The above will produce "erroneous" code
|
||||
# if the hex constant was e.g. inside UINT64_C
|
||||
# macro, but then again, h2ph is an approximation.
|
||||
} else {
|
||||
$new .= lc("0x$hex");
|
||||
}
|
||||
next;};
|
||||
s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
|
||||
s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
|
||||
s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
|
||||
s/^'((\\"|[^"])*)'// && do {
|
||||
if ($curargs{$1}) {
|
||||
$new .= "ord('\$$1')";
|
||||
} else {
|
||||
$new .= "ord('$1')";
|
||||
}
|
||||
next;
|
||||
};
|
||||
# replace "sizeof(foo)" with "{foo}"
|
||||
# also, remove * (C dereference operator) to avoid perl syntax
|
||||
# problems. Where the %sizeof array comes from is anyone's
|
||||
# guess (c2ph?), but this at least avoids fatal syntax errors.
|
||||
# Behavior is undefined if sizeof() delimiters are unbalanced.
|
||||
# This code was modified to able to handle constructs like this:
|
||||
# sizeof(*(p)), which appear in the HP-UX 10.01 header files.
|
||||
s/^sizeof\s*\(// && do {
|
||||
$new .= '$sizeof';
|
||||
my $lvl = 1; # already saw one open paren
|
||||
# tack { on the front, and skip it in the loop
|
||||
$_ = "{" . "$_";
|
||||
my $index = 1;
|
||||
# find balanced closing paren
|
||||
while ($index <= length($_) && $lvl > 0) {
|
||||
$lvl++ if substr($_, $index, 1) eq "(";
|
||||
$lvl-- if substr($_, $index, 1) eq ")";
|
||||
$index++;
|
||||
}
|
||||
# tack } on the end, replacing )
|
||||
substr($_, $index - 1, 1) = "}";
|
||||
# remove pesky * operators within the sizeof argument
|
||||
substr($_, 0, $index - 1) =~ s/\*//g;
|
||||
next;
|
||||
};
|
||||
# Eliminate typedefs
|
||||
/\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
|
||||
my $doit = 1;
|
||||
foreach (split /\s+/, $1) { # Make sure all the words are types,
|
||||
unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
|
||||
$doit = 0;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if( $doit ){
|
||||
s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
|
||||
}
|
||||
};
|
||||
# struct/union member, including arrays:
|
||||
s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
|
||||
my $id = $1;
|
||||
$id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
|
||||
$id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
|
||||
while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
|
||||
my($index) = $1;
|
||||
$index =~ s/\s//g;
|
||||
if(exists($curargs{$index})) {
|
||||
$index = "\$$index";
|
||||
} else {
|
||||
$index = "&$index";
|
||||
}
|
||||
$id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
|
||||
}
|
||||
$new .= " (\$$id)";
|
||||
};
|
||||
s/^([_a-zA-Z]\w*)// && do {
|
||||
my $id = $1;
|
||||
if ($id eq 'struct' || $id eq 'union') {
|
||||
s/^\s+(\w+)//;
|
||||
$id .= ' ' . $1;
|
||||
$isatype{$id} = 1;
|
||||
} elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
|
||||
while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
|
||||
$isatype{$id} = 1;
|
||||
}
|
||||
if ($curargs{$id}) {
|
||||
$new .= "\$$id";
|
||||
$new .= '->' if /^[\[\{]/;
|
||||
} elsif ($id eq 'defined') {
|
||||
$new .= 'defined';
|
||||
} elsif (/^\s*\(/) {
|
||||
s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
|
||||
$new .= " &$id";
|
||||
} elsif ($isatype{$id}) {
|
||||
if ($new =~ /\{\s*$/) {
|
||||
$new .= "'$id'";
|
||||
} elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
|
||||
$new =~ s/\(\s*$//;
|
||||
s/^[\s*]*\)//;
|
||||
} else {
|
||||
$new .= q(').$id.q(');
|
||||
}
|
||||
} else {
|
||||
if ($inif) {
|
||||
if ($new =~ /defined\s*$/) {
|
||||
$new .= '(&' . $id . ')';
|
||||
} elsif ($new =~ /defined\s*\($/) {
|
||||
$new .= '&' . $id;
|
||||
} else {
|
||||
$new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)';
|
||||
}
|
||||
} elsif (/^\[/) {
|
||||
$new .= " \$$id";
|
||||
} else {
|
||||
$new .= ' &' . $id;
|
||||
}
|
||||
}
|
||||
next;
|
||||
};
|
||||
s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub next_line
|
||||
{
|
||||
my $file = shift;
|
||||
my ($in, $out);
|
||||
my $pre_sub_tri_graphs = 1;
|
||||
|
||||
READ: while (not eof IN) {
|
||||
$in .= <IN>;
|
||||
chomp $in;
|
||||
next unless length $in;
|
||||
|
||||
while (length $in) {
|
||||
if ($pre_sub_tri_graphs) {
|
||||
# Preprocess all tri-graphs
|
||||
# including things stuck in quoted string constants.
|
||||
$in =~ s/\?\?=/#/g; # | ??=| #|
|
||||
$in =~ s/\?\?\!/|/g; # | ??!| ||
|
||||
$in =~ s/\?\?'/^/g; # | ??'| ^|
|
||||
$in =~ s/\?\?\(/[/g; # | ??(| [|
|
||||
$in =~ s/\?\?\)/]/g; # | ??)| ]|
|
||||
$in =~ s/\?\?\-/~/g; # | ??-| ~|
|
||||
$in =~ s/\?\?\//\\/g; # | ??/| \|
|
||||
$in =~ s/\?\?</{/g; # | ??<| {|
|
||||
$in =~ s/\?\?>/}/g; # | ??>| }|
|
||||
}
|
||||
if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
|
||||
# Tru64 disassembler.h evilness: mixed C and Pascal.
|
||||
while (<IN>) {
|
||||
last if /^\#endif/;
|
||||
}
|
||||
$in = "";
|
||||
next READ;
|
||||
}
|
||||
if ($in =~ /^extern inline / && # Inlined assembler.
|
||||
$^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
|
||||
while (<IN>) {
|
||||
last if /^}/;
|
||||
}
|
||||
$in = "";
|
||||
next READ;
|
||||
}
|
||||
if ($in =~ s/\\$//) { # \-newline
|
||||
$out .= ' ';
|
||||
next READ;
|
||||
} elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
|
||||
$out .= $1;
|
||||
} elsif ($in =~ s/^(\\.)//) { # \...
|
||||
$out .= $1;
|
||||
} elsif ($in =~ /^'/) { # '...
|
||||
if ($in =~ s/^('(\\.|[^'\\])*')//) {
|
||||
$out .= $1;
|
||||
} else {
|
||||
next READ;
|
||||
}
|
||||
} elsif ($in =~ /^"/) { # "...
|
||||
if ($in =~ s/^("(\\.|[^"\\])*")//) {
|
||||
$out .= $1;
|
||||
} else {
|
||||
next READ;
|
||||
}
|
||||
} elsif ($in =~ s/^\/\/.*//) { # //...
|
||||
# fall through
|
||||
} elsif ($in =~ m/^\/\*/) { # /*...
|
||||
# C comment removal adapted from perlfaq6:
|
||||
if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
|
||||
$out .= ' ';
|
||||
} else { # Incomplete /* */
|
||||
next READ;
|
||||
}
|
||||
} elsif ($in =~ s/^(\/)//) { # /...
|
||||
$out .= $1;
|
||||
} elsif ($in =~ s/^([^\'\"\\\/]+)//) {
|
||||
$out .= $1;
|
||||
} elsif ($^O eq 'linux' &&
|
||||
$file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
|
||||
$in =~ s!\'T KNOW!!) {
|
||||
$out =~ s!I DON$!I_DO_NOT_KNOW!;
|
||||
} else {
|
||||
if ($opt_e) {
|
||||
warn "Cannot parse $file:\n$in\n";
|
||||
$bad_file{$file} = 1;
|
||||
$in = '';
|
||||
$out = undef;
|
||||
last READ;
|
||||
} else {
|
||||
die "Cannot parse:\n$in\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
last READ if $out =~ /\S/;
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
# Handle recursive subdirectories without getting a grotesquely big stack.
|
||||
# Could this be implemented using File::Find?
|
||||
sub next_file
|
||||
{
|
||||
my $file;
|
||||
|
||||
while (@ARGV) {
|
||||
$file = shift @ARGV;
|
||||
|
||||
if ($file eq '-' or -f $file or -l $file) {
|
||||
return $file;
|
||||
} elsif (-d $file) {
|
||||
if ($opt_r) {
|
||||
expand_glob($file);
|
||||
} else {
|
||||
print STDERR "Skipping directory '$file'\n";
|
||||
}
|
||||
} elsif ($opt_a) {
|
||||
return $file;
|
||||
} else {
|
||||
print STDERR "Skipping '$file': not a file or directory\n";
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
# Put all the files in $directory into @ARGV for processing.
|
||||
sub expand_glob
|
||||
{
|
||||
my ($directory) = @_;
|
||||
|
||||
$directory =~ s:/$::;
|
||||
|
||||
opendir DIR, $directory;
|
||||
foreach (readdir DIR) {
|
||||
next if ($_ eq '.' or $_ eq '..');
|
||||
|
||||
# expand_glob() is going to be called until $ARGV[0] isn't a
|
||||
# directory; so push directories, and unshift everything else.
|
||||
if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
|
||||
else { unshift @ARGV, "$directory/$_" }
|
||||
}
|
||||
closedir DIR;
|
||||
}
|
||||
|
||||
|
||||
# Given $file, a symbolic link to a directory in the C include directory,
|
||||
# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
|
||||
# Otherwise, just duplicate the file or directory.
|
||||
sub link_if_possible
|
||||
{
|
||||
my ($dirlink) = @_;
|
||||
my $target = eval 'readlink($dirlink)';
|
||||
|
||||
if ($target =~ m:^\.\./: or $target =~ m:^/:) {
|
||||
# The target of a parent or absolute link could leave the $Dest_dir
|
||||
# hierarchy, so let's put all of the contents of $dirlink (actually,
|
||||
# the contents of $target) into @ARGV; as a side effect down the
|
||||
# line, $dirlink will get created as an _actual_ directory.
|
||||
expand_glob($dirlink);
|
||||
} else {
|
||||
if (-l "$Dest_dir/$dirlink") {
|
||||
unlink "$Dest_dir/$dirlink" or
|
||||
print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
|
||||
}
|
||||
|
||||
if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
|
||||
print "Linking $target -> $Dest_dir/$dirlink\n";
|
||||
|
||||
# Make sure that the link _links_ to something:
|
||||
if (! -e "$Dest_dir/$target") {
|
||||
mkpath("$Dest_dir/$target", 0755) or
|
||||
print STDERR "Could not create $Dest_dir/$target/\n";
|
||||
}
|
||||
} else {
|
||||
print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Push all #included files in $file onto our stack, except for STDIN
|
||||
# and files we've already processed.
|
||||
sub queue_includes_from
|
||||
{
|
||||
my ($file) = @_;
|
||||
my $line;
|
||||
|
||||
return if ($file eq "-");
|
||||
|
||||
open HEADER, $file or return;
|
||||
while (defined($line = <HEADER>)) {
|
||||
while (/\\$/) { # Handle continuation lines
|
||||
chop $line;
|
||||
$line .= <HEADER>;
|
||||
}
|
||||
|
||||
if ($line =~ /^#\s*include\s+([<"])(.*?)[>"]/) {
|
||||
my ($delimiter, $new_file) = ($1, $2);
|
||||
# copy the prefix in the quote syntax (#include "x.h") case
|
||||
if ($delimiter eq q{"} && $file =~ m|^(.*)/|) {
|
||||
$new_file = "$1/$new_file";
|
||||
}
|
||||
push(@ARGV, $new_file) unless $Is_converted{$new_file};
|
||||
}
|
||||
}
|
||||
close HEADER;
|
||||
}
|
||||
|
||||
|
||||
# Determine include directories; $Config{usrinc} should be enough for (all
|
||||
# non-GCC?) C compilers, but gcc uses additional include directories.
|
||||
sub inc_dirs
|
||||
{
|
||||
my $from_gcc = `LC_ALL=C $Config{cc} -v -E - < /dev/null 2>&1 | awk '/^#include/, /^End of search list/' | grep '^ '`;
|
||||
length($from_gcc) ? (split(' ', $from_gcc), $Config{usrinc}) : ($Config{usrinc});
|
||||
}
|
||||
|
||||
|
||||
# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
|
||||
# version of h2ph.
|
||||
sub build_preamble_if_necessary
|
||||
{
|
||||
# Increment $VERSION every time this function is modified:
|
||||
my $VERSION = 4;
|
||||
my $preamble = "$Dest_dir/_h2ph_pre.ph";
|
||||
|
||||
# Can we skip building the preamble file?
|
||||
if (-r $preamble) {
|
||||
# Extract version number from first line of preamble:
|
||||
open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
|
||||
my $line = <PREAMBLE>;
|
||||
$line =~ /(\b\d+\b)/;
|
||||
close PREAMBLE or die "Cannot close $preamble: $!";
|
||||
|
||||
# Don't build preamble if a compatible preamble exists:
|
||||
return if $1 == $VERSION;
|
||||
}
|
||||
|
||||
my (%define) = _extract_cc_defines();
|
||||
|
||||
open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
|
||||
print PREAMBLE "# This file was created by h2ph version $VERSION\n";
|
||||
# Prevent non-portable hex constants from warning.
|
||||
#
|
||||
# We still produce an overflow warning if we can't represent
|
||||
# a hex constant as an integer.
|
||||
print PREAMBLE "no warnings qw(portable);\n";
|
||||
|
||||
foreach (sort keys %define) {
|
||||
if ($opt_D) {
|
||||
print PREAMBLE "# $_=$define{$_}\n";
|
||||
}
|
||||
if ($define{$_} =~ /^\((.*)\)$/) {
|
||||
# parenthesized value: d=(v)
|
||||
$define{$_} = $1;
|
||||
}
|
||||
if (/^(\w+)\((\w)\)$/) {
|
||||
my($macro, $arg) = ($1, $2);
|
||||
my $def = $define{$_};
|
||||
$def =~ s/$arg/\$\{$arg\}/g;
|
||||
print PREAMBLE <<DEFINE;
|
||||
unless (defined &$macro) { sub $macro(\$) { my (\$$arg) = \@_; \"$def\" } }
|
||||
|
||||
DEFINE
|
||||
} elsif
|
||||
($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
|
||||
# float:
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $1 } }\n\n";
|
||||
} elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
|
||||
# integer:
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $1 } }\n\n";
|
||||
} elsif ($define{$_} =~ /^([+-]?0x[\da-f]+)U?L{0,2}$/i) {
|
||||
# hex integer
|
||||
# Special cased, since perl warns on hex integers
|
||||
# that can't be represented in a UV.
|
||||
#
|
||||
# This way we get the warning at time of use, so the user
|
||||
# only gets the warning if they happen to use this
|
||||
# platform-specific definition.
|
||||
my $code = $1;
|
||||
$code = "hex('$code')" if length $code > 10;
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { $code } }\n\n";
|
||||
} elsif ($define{$_} =~ /^\w+$/) {
|
||||
my $def = $define{$_};
|
||||
if ($isatype{$def}) {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { \"$def\" } }\n\n";
|
||||
} else {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { &$def } }\n\n";
|
||||
}
|
||||
} else {
|
||||
print PREAMBLE
|
||||
"unless (defined &$_) { sub $_() { \"",
|
||||
quotemeta($define{$_}), "\" } }\n\n";
|
||||
}
|
||||
}
|
||||
print PREAMBLE "\n1;\n"; # avoid 'did not return a true value' when empty
|
||||
close PREAMBLE or die "Cannot close $preamble: $!";
|
||||
}
|
||||
|
||||
|
||||
# %Config contains information on macros that are pre-defined by the
|
||||
# system's compiler. We need this information to make the .ph files
|
||||
# function with perl as the .h files do with cc.
|
||||
sub _extract_cc_defines
|
||||
{
|
||||
my %define;
|
||||
my $allsymbols = join " ",
|
||||
@Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
|
||||
|
||||
# Split compiler pre-definitions into 'key=value' pairs:
|
||||
while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
|
||||
$define{$1} = $2;
|
||||
if ($opt_D) {
|
||||
print STDERR "$_: $1 -> $2\n";
|
||||
}
|
||||
}
|
||||
|
||||
return %define;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
##############################################################################
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
h2ph - convert .h C header files to .ph Perl header files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<h2ph [-d destination directory] [-r | -a] [-l] [-h] [-e] [-D] [-Q]
|
||||
[headerfiles]>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
I<h2ph>
|
||||
converts any C header files specified to the corresponding Perl header file
|
||||
format.
|
||||
It is most easily run while in /usr/include:
|
||||
|
||||
cd /usr/include; h2ph * sys/*
|
||||
|
||||
or
|
||||
|
||||
cd /usr/include; h2ph * sys/* arpa/* netinet/*
|
||||
|
||||
or
|
||||
|
||||
cd /usr/include; h2ph -r -l .
|
||||
|
||||
The output files are placed in the hierarchy rooted at Perl's
|
||||
architecture dependent library directory. You can specify a different
|
||||
hierarchy with a B<-d> switch.
|
||||
|
||||
If run with no arguments, filters standard input to standard output.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item -d destination_dir
|
||||
|
||||
Put the resulting B<.ph> files beneath B<destination_dir>, instead of
|
||||
beneath the default Perl library location (C<$Config{'installsitearch'}>).
|
||||
|
||||
=item -r
|
||||
|
||||
Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
|
||||
on all files in those directories (and their subdirectories, etc.). B<-r>
|
||||
and B<-a> are mutually exclusive.
|
||||
|
||||
=item -a
|
||||
|
||||
Run automagically; convert B<headerfiles>, as well as any B<.h> files
|
||||
which they include. This option will search for B<.h> files in all
|
||||
directories which your C compiler ordinarily uses. B<-a> and B<-r> are
|
||||
mutually exclusive.
|
||||
|
||||
=item -l
|
||||
|
||||
Symbolic links will be replicated in the destination directory. If B<-l>
|
||||
is not specified, then links are skipped over.
|
||||
|
||||
=item -h
|
||||
|
||||
Put 'hints' in the .ph files which will help in locating problems with
|
||||
I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
|
||||
errors, instead of the cryptic
|
||||
|
||||
[ some error condition ] at (eval mmm) line nnn
|
||||
|
||||
you will see the slightly more helpful
|
||||
|
||||
[ some error condition ] at filename.ph line nnn
|
||||
|
||||
However, the B<.ph> files almost double in size when built using B<-h>.
|
||||
|
||||
=item -e
|
||||
|
||||
If an error is encountered during conversion, output file will be removed and
|
||||
a warning emitted instead of terminating the conversion immediately.
|
||||
|
||||
=item -D
|
||||
|
||||
Include the code from the B<.h> file as a comment in the B<.ph> file.
|
||||
This is primarily used for debugging I<h2ph>.
|
||||
|
||||
=item -Q
|
||||
|
||||
'Quiet' mode; don't print out the names of the files being converted.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
No environment variables are used.
|
||||
|
||||
=head1 FILES
|
||||
|
||||
/usr/include/*.h
|
||||
/usr/include/sys/*.h
|
||||
|
||||
etc.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Larry Wall
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1)
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
The usual warnings if it can't read or write the files involved.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Doesn't construct the %sizeof array for you.
|
||||
|
||||
It doesn't handle all C constructs, but it does attempt to isolate
|
||||
definitions inside evals so that you can get at the definitions
|
||||
that it can translate.
|
||||
|
||||
It's only intended as a rough tool.
|
||||
You may need to dicker with the files produced.
|
||||
|
||||
You have to run this program by hand; it's not run as part of the Perl
|
||||
installation.
|
||||
|
||||
Doesn't handle complicated expressions built piecemeal, a la:
|
||||
|
||||
enum {
|
||||
FIRST_VALUE,
|
||||
SECOND_VALUE,
|
||||
#ifdef ABC
|
||||
THIRD_VALUE
|
||||
#endif
|
||||
};
|
||||
|
||||
Doesn't necessarily locate all of your C compiler's internally-defined
|
||||
symbols.
|
||||
|
||||
=cut
|
||||
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,52 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Getopt::Long qw(GetOptions :config no_auto_abbrev no_ignore_case);
|
||||
|
||||
GetOptions
|
||||
'f|foreground' => \$ENV{HYPNOTOAD_FOREGROUND},
|
||||
'h|help' => \my $help,
|
||||
's|stop' => \$ENV{HYPNOTOAD_STOP},
|
||||
't|test' => \$ENV{HYPNOTOAD_TEST};
|
||||
|
||||
my $app = shift || $ENV{HYPNOTOAD_APP};
|
||||
if ($help || !$app) {
|
||||
require Mojolicious::Command;
|
||||
die Mojolicious::Command->new->extract_usage;
|
||||
}
|
||||
|
||||
require Mojo::Server::Hypnotoad;
|
||||
Mojo::Server::Hypnotoad->new->run($app);
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
hypnotoad - Hypnotoad HTTP and WebSocket server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Usage: hypnotoad [OPTIONS] [APPLICATION]
|
||||
|
||||
hypnotoad ./script/my_app
|
||||
hypnotoad ./myapp.pl
|
||||
hypnotoad -f ./myapp.pl
|
||||
|
||||
Options:
|
||||
-f, --foreground Keep manager process in foreground
|
||||
-h, --help Show this message
|
||||
-s, --stop Stop server gracefully
|
||||
-t, --test Test application and exit
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Start L<Mojolicious> and L<Mojolicious::Lite> applications with the
|
||||
L<Mojo::Server::Hypnotoad> web server.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,195 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use strict;
|
||||
use IO::File;
|
||||
use ExtUtils::Packlist;
|
||||
use ExtUtils::Installed;
|
||||
|
||||
use vars qw($Inst @Modules);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
instmodsh - A shell to examine installed modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
instmodsh
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A little interface to ExtUtils::Installed to examine installed modules,
|
||||
validate your packlists and even create a tarball from an installed module.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
ExtUtils::Installed
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
my $Module_Help = <<EOF;
|
||||
Available commands are:
|
||||
f [all|prog|doc] - List installed files of a given type
|
||||
d [all|prog|doc] - List the directories used by a module
|
||||
v - Validate the .packlist - check for missing files
|
||||
t <tarfile> - Create a tar archive of the module
|
||||
h - Display module help
|
||||
q - Quit the module
|
||||
EOF
|
||||
|
||||
my %Module_Commands = (
|
||||
f => \&list_installed,
|
||||
d => \&list_directories,
|
||||
v => \&validate_packlist,
|
||||
t => \&create_archive,
|
||||
h => \&module_help,
|
||||
);
|
||||
|
||||
sub do_module($) {
|
||||
my ($module) = @_;
|
||||
|
||||
print($Module_Help);
|
||||
MODULE_CMD: while (1) {
|
||||
print("$module cmd? ");
|
||||
|
||||
my $reply = <STDIN>; chomp($reply);
|
||||
my($cmd) = $reply =~ /^(\w)\b/;
|
||||
|
||||
last if $cmd eq 'q';
|
||||
|
||||
if( $Module_Commands{$cmd} ) {
|
||||
$Module_Commands{$cmd}->($reply, $module);
|
||||
}
|
||||
elsif( $cmd eq 'q' ) {
|
||||
last MODULE_CMD;
|
||||
}
|
||||
else {
|
||||
module_help();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub list_installed {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $class = (split(' ', $reply))[1];
|
||||
$class = 'all' unless $class;
|
||||
|
||||
my @files;
|
||||
if (eval { @files = $Inst->files($module, $class); }) {
|
||||
print("$class files in $module are:\n ",
|
||||
join("\n ", @files), "\n");
|
||||
}
|
||||
else {
|
||||
print($@);
|
||||
}
|
||||
};
|
||||
|
||||
|
||||
sub list_directories {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $class = (split(' ', $reply))[1];
|
||||
$class = 'all' unless $class;
|
||||
|
||||
my @dirs;
|
||||
if (eval { @dirs = $Inst->directories($module, $class); }) {
|
||||
print("$class directories in $module are:\n ",
|
||||
join("\n ", @dirs), "\n");
|
||||
}
|
||||
else {
|
||||
print($@);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub create_archive {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
my $file = (split(' ', $reply))[1];
|
||||
|
||||
if( !(defined $file and length $file) ) {
|
||||
print "No tar file specified\n";
|
||||
}
|
||||
elsif( eval { require Archive::Tar } ) {
|
||||
Archive::Tar->create_archive($file, 0, $Inst->files($module));
|
||||
}
|
||||
else {
|
||||
my($first, @rest) = $Inst->files($module);
|
||||
system('tar', 'cvf', $file, $first);
|
||||
for my $f (@rest) {
|
||||
system('tar', 'rvf', $file, $f);
|
||||
}
|
||||
print "Can't use tar\n" if $?;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub validate_packlist {
|
||||
my($reply, $module) = @_;
|
||||
|
||||
if (my @missing = $Inst->validate($module)) {
|
||||
print("Files missing from $module are:\n ",
|
||||
join("\n ", @missing), "\n");
|
||||
}
|
||||
else {
|
||||
print("$module has no missing files\n");
|
||||
}
|
||||
}
|
||||
|
||||
sub module_help {
|
||||
print $Module_Help;
|
||||
}
|
||||
|
||||
|
||||
|
||||
##############################################################################
|
||||
|
||||
sub toplevel()
|
||||
{
|
||||
my $help = <<EOF;
|
||||
Available commands are:
|
||||
l - List all installed modules
|
||||
m <module> - Select a module
|
||||
q - Quit the program
|
||||
EOF
|
||||
print($help);
|
||||
while (1)
|
||||
{
|
||||
print("cmd? ");
|
||||
my $reply = <STDIN>; chomp($reply);
|
||||
CASE:
|
||||
{
|
||||
$reply eq 'l' and do
|
||||
{
|
||||
print("Installed modules are:\n ", join("\n ", @Modules), "\n");
|
||||
last CASE;
|
||||
};
|
||||
$reply =~ /^m\s+/ and do
|
||||
{
|
||||
do_module((split(' ', $reply))[1]);
|
||||
last CASE;
|
||||
};
|
||||
$reply eq 'q' and do
|
||||
{
|
||||
exit(0);
|
||||
};
|
||||
# Default
|
||||
print($help);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
###############################################################################
|
||||
|
||||
$Inst = ExtUtils::Installed->new();
|
||||
@Modules = $Inst->modules();
|
||||
toplevel();
|
||||
|
||||
###############################################################################
|
||||
|
|
@ -0,0 +1,208 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use Getopt::Long;
|
||||
|
||||
use JSON::PP ();
|
||||
|
||||
my $VERSION = '1.00';
|
||||
|
||||
# imported from JSON-XS/bin/json_xs
|
||||
|
||||
my %allow_json_opt = map { $_ => 1 } qw(
|
||||
ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
|
||||
allow_singlequote allow_barekey allow_bignum loose escape_slash
|
||||
);
|
||||
|
||||
|
||||
GetOptions(
|
||||
'v' => \( my $opt_verbose ),
|
||||
'f=s' => \( my $opt_from = 'json' ),
|
||||
't=s' => \( my $opt_to = 'json' ),
|
||||
'json_opt=s' => \( my $json_opt = 'pretty' ),
|
||||
'V' => \( my $version ),
|
||||
) or die "Usage: $0 [-v] -f from_format [-t to_format]\n";
|
||||
|
||||
|
||||
if ( $version ) {
|
||||
print "$VERSION\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
|
||||
$json_opt = '' if $json_opt eq '-';
|
||||
|
||||
my @json_opt = grep { $allow_json_opt{ $_ } or die "'$_' is invalid json opttion" } split/,/, $json_opt;
|
||||
|
||||
my %F = (
|
||||
'json' => sub {
|
||||
my $json = JSON::PP->new;
|
||||
$json->$_() for @json_opt;
|
||||
$json->decode( $_ );
|
||||
},
|
||||
'eval' => sub {
|
||||
my $v = eval "no strict;\n#line 1 \"input\"\n$_";
|
||||
die "$@" if $@;
|
||||
return $v;
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
my %T = (
|
||||
'null' => sub { "" },
|
||||
'json' => sub {
|
||||
my $json = JSON::PP->new;
|
||||
$json->$_() for @json_opt;
|
||||
$json->encode( $_ );
|
||||
},
|
||||
'dumper' => sub {
|
||||
require Data::Dumper;
|
||||
Data::Dumper::Dumper($_)
|
||||
},
|
||||
);
|
||||
|
||||
|
||||
|
||||
$F{$opt_from}
|
||||
or die "$opt_from: not a valid fromformat\n";
|
||||
|
||||
$T{$opt_to}
|
||||
or die "$opt_from: not a valid toformat\n";
|
||||
|
||||
local $/;
|
||||
$_ = <STDIN>;
|
||||
|
||||
$_ = $F{$opt_from}->();
|
||||
$_ = $T{$opt_to}->();
|
||||
|
||||
print $_;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
json_pp - JSON::PP command utility
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
json_pp [-v] [-f from_format] [-t to_format] [-json_opt options_to_json]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
json_pp converts between some input and output formats (one of them is JSON).
|
||||
This program was copied from L<json_xs> and modified.
|
||||
|
||||
The default input format is json and the default output format is json with pretty option.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=head2 -f
|
||||
|
||||
-f from_format
|
||||
|
||||
Reads a data in the given format from STDIN.
|
||||
|
||||
Format types:
|
||||
|
||||
=over
|
||||
|
||||
=item json
|
||||
|
||||
as JSON
|
||||
|
||||
=item eval
|
||||
|
||||
as Perl code
|
||||
|
||||
=back
|
||||
|
||||
=head2 -t
|
||||
|
||||
Writes a data in the given format to STDOUT.
|
||||
|
||||
=over
|
||||
|
||||
=item null
|
||||
|
||||
no action.
|
||||
|
||||
=item json
|
||||
|
||||
as JSON
|
||||
|
||||
=item dumper
|
||||
|
||||
as Data::Dumper
|
||||
|
||||
=back
|
||||
|
||||
=head2 -json_opt
|
||||
|
||||
options to JSON::PP
|
||||
|
||||
Acceptable options are:
|
||||
|
||||
ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
|
||||
allow_singlequote allow_barekey allow_bignum loose escape_slash
|
||||
|
||||
=head2 -v
|
||||
|
||||
Verbose option, but currently no action in fact.
|
||||
|
||||
=head2 -V
|
||||
|
||||
Prints version and exits.
|
||||
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
$ perl -e'print q|{"foo":"あい","bar":1234567890000000000000000}|' |\
|
||||
json_pp -f json -t dumper -json_opt pretty,utf8,allow_bignum
|
||||
|
||||
$VAR1 = {
|
||||
'bar' => bless( {
|
||||
'value' => [
|
||||
'0000000',
|
||||
'0000000',
|
||||
'5678900',
|
||||
'1234'
|
||||
],
|
||||
'sign' => '+'
|
||||
}, 'Math::BigInt' ),
|
||||
'foo' => "\x{3042}\x{3044}"
|
||||
};
|
||||
|
||||
$ perl -e'print q|{"foo":"あい","bar":1234567890000000000000000}|' |\
|
||||
json_pp -f json -t dumper -json_opt pretty
|
||||
|
||||
$VAR1 = {
|
||||
'bar' => '1234567890000000000000000',
|
||||
'foo' => "\x{e3}\x{81}\x{82}\x{e3}\x{81}\x{84}"
|
||||
};
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<JSON::PP>, L<json_xs>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2010 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -0,0 +1,721 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
libnetcfg - configure libnet
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The libnetcfg utility can be used to configure the libnet.
|
||||
Starting from perl 5.8 libnet is part of the standard Perl
|
||||
distribution, but the libnetcfg can be used for any libnet
|
||||
installation.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
Without arguments libnetcfg displays the current configuration.
|
||||
|
||||
$ libnetcfg
|
||||
# old config ./libnet.cfg
|
||||
daytime_hosts ntp1.none.such
|
||||
ftp_int_passive 0
|
||||
ftp_testhost ftp.funet.fi
|
||||
inet_domain none.such
|
||||
nntp_hosts nntp.none.such
|
||||
ph_hosts
|
||||
pop3_hosts pop.none.such
|
||||
smtp_hosts smtp.none.such
|
||||
snpp_hosts
|
||||
test_exist 1
|
||||
test_hosts 1
|
||||
time_hosts ntp.none.such
|
||||
# libnetcfg -h for help
|
||||
$
|
||||
|
||||
It tells where the old configuration file was found (if found).
|
||||
|
||||
The C<-h> option will show a usage message.
|
||||
|
||||
To change the configuration you will need to use either the C<-c> or
|
||||
the C<-d> options.
|
||||
|
||||
The default name of the old configuration file is by default
|
||||
"libnet.cfg", unless otherwise specified using the -i option,
|
||||
C<-i oldfile>, and it is searched first from the current directory,
|
||||
and then from your module path.
|
||||
|
||||
The default name of the new configuration file is "libnet.cfg", and by
|
||||
default it is written to the current directory, unless otherwise
|
||||
specified using the -o option, C<-o newfile>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Net::Config>, L<libnetFAQ>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Graham Barr, the original Configure script of libnet.
|
||||
|
||||
Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
|
||||
|
||||
=cut
|
||||
|
||||
# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
|
||||
|
||||
use strict;
|
||||
use IO::File;
|
||||
use Getopt::Std;
|
||||
use ExtUtils::MakeMaker qw(prompt);
|
||||
use File::Spec;
|
||||
|
||||
use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
my %cfg = ();
|
||||
my @cfg = ();
|
||||
|
||||
my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub valid_host
|
||||
{
|
||||
my $h = shift;
|
||||
|
||||
defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub test_hostnames (\@)
|
||||
{
|
||||
my $hlist = shift;
|
||||
my @h = ();
|
||||
my $host;
|
||||
my $err = 0;
|
||||
|
||||
foreach $host (@$hlist)
|
||||
{
|
||||
if(valid_host($host))
|
||||
{
|
||||
push(@h, $host);
|
||||
next;
|
||||
}
|
||||
warn "Bad hostname: '$host'\n";
|
||||
$err++;
|
||||
}
|
||||
@$hlist = @h;
|
||||
$err ? join(" ",@h) : undef;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub Prompt
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
$def = "" unless defined $def;
|
||||
|
||||
chomp($prompt);
|
||||
|
||||
if($opt_d)
|
||||
{
|
||||
print $prompt,," [",$def,"]\n";
|
||||
return $def;
|
||||
}
|
||||
prompt($prompt,$def);
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_host_list
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
$def = join(" ",@$def) if ref($def);
|
||||
|
||||
my @hosts;
|
||||
|
||||
do
|
||||
{
|
||||
my $ans = Prompt($prompt,$def);
|
||||
|
||||
$ans =~ s/(\A\s+|\s+\Z)//g;
|
||||
|
||||
@hosts = split(/\s+/, $ans);
|
||||
}
|
||||
while(@hosts && defined($def = test_hostnames(@hosts)));
|
||||
|
||||
\@hosts;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_hostname
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
my $host;
|
||||
|
||||
while(1)
|
||||
{
|
||||
my $ans = Prompt($prompt,$def);
|
||||
$host = ($ans =~ /(\S*)/)[0];
|
||||
last
|
||||
if(!length($host) || valid_host($host));
|
||||
|
||||
$def =""
|
||||
if $def eq $host;
|
||||
|
||||
print <<"EDQ";
|
||||
|
||||
*** ERROR:
|
||||
Hostname '$host' does not seem to exist, please enter again
|
||||
or a single space to clear any default
|
||||
|
||||
EDQ
|
||||
}
|
||||
|
||||
length $host
|
||||
? $host
|
||||
: undef;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_bool ($$)
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
chomp($prompt);
|
||||
|
||||
my $val = Prompt($prompt,$def ? "yes" : "no");
|
||||
|
||||
$val =~ /^y/i ? 1 : 0;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub get_netmask ($$)
|
||||
{
|
||||
my($prompt,$def) = @_;
|
||||
|
||||
chomp($prompt);
|
||||
|
||||
my %list;
|
||||
@list{@$def} = ();
|
||||
|
||||
MASK:
|
||||
while(1) {
|
||||
my $bad = 0;
|
||||
my $ans = Prompt($prompt) or last;
|
||||
|
||||
if($ans eq '*') {
|
||||
%list = ();
|
||||
next;
|
||||
}
|
||||
|
||||
if($ans eq '=') {
|
||||
print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
|
||||
next;
|
||||
}
|
||||
|
||||
unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
|
||||
warn "Bad netmask '$ans'\n";
|
||||
next;
|
||||
}
|
||||
|
||||
my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0);
|
||||
if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
|
||||
warn "Bad netmask '$ans'\n";
|
||||
next MASK;
|
||||
}
|
||||
foreach my $byte (@ip) {
|
||||
if ( $byte > 255 ) {
|
||||
warn "Bad netmask '$ans'\n";
|
||||
next MASK;
|
||||
}
|
||||
}
|
||||
|
||||
my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits);
|
||||
|
||||
if ($remove) {
|
||||
delete $list{$mask};
|
||||
}
|
||||
else {
|
||||
$list{$mask} = 1;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
[ keys %list ];
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
sub default_hostname
|
||||
{
|
||||
my $host;
|
||||
my @host;
|
||||
|
||||
foreach $host (@_)
|
||||
{
|
||||
if(defined($host) && valid_host($host))
|
||||
{
|
||||
return $host
|
||||
unless wantarray;
|
||||
push(@host,$host);
|
||||
}
|
||||
}
|
||||
|
||||
return wantarray ? @host : undef;
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
getopts('dcho:i:');
|
||||
|
||||
$libnet_cfg_in = "libnet.cfg"
|
||||
unless(defined($libnet_cfg_in = $opt_i));
|
||||
|
||||
$libnet_cfg_out = "libnet.cfg"
|
||||
unless(defined($libnet_cfg_out = $opt_o));
|
||||
|
||||
my %oldcfg = ();
|
||||
|
||||
$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
|
||||
if( -f $libnet_cfg_in )
|
||||
{
|
||||
%oldcfg = ( %{ do $libnet_cfg_in } );
|
||||
}
|
||||
elsif (eval { require Net::Config })
|
||||
{
|
||||
$have_old = 1;
|
||||
%oldcfg = %Net::Config::NetConfig;
|
||||
}
|
||||
|
||||
map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
if ($opt_h) {
|
||||
print <<EOU;
|
||||
$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
|
||||
Without options, the old configuration is shown.
|
||||
|
||||
-c change the configuration
|
||||
-d use defaults from the old config (implies -c, non-interactive)
|
||||
-i use a specific file as the old config file
|
||||
-o use a specific file as the new config file
|
||||
-h show this help
|
||||
|
||||
The default name of the old configuration file is by default
|
||||
"libnet.cfg", unless otherwise specified using the -i option,
|
||||
C<-i oldfile>, and it is searched first from the current directory,
|
||||
and then from your module path.
|
||||
|
||||
The default name of the new configuration file is "libnet.cfg", and by
|
||||
default it is written to the current directory, unless otherwise
|
||||
specified using the -o option.
|
||||
|
||||
EOU
|
||||
exit(0);
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
{
|
||||
my $oldcfgfile;
|
||||
my @inc;
|
||||
push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
|
||||
push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB};
|
||||
push @inc, @INC;
|
||||
for (@inc) {
|
||||
my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
|
||||
if (-f $trycfgfile && -r $trycfgfile) {
|
||||
$oldcfgfile = $trycfgfile;
|
||||
last;
|
||||
}
|
||||
}
|
||||
print "# old config $oldcfgfile\n" if defined $oldcfgfile;
|
||||
for (sort keys %oldcfg) {
|
||||
printf "%-20s %s\n", $_,
|
||||
ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
|
||||
}
|
||||
unless ($opt_c || $opt_d) {
|
||||
print "# $0 -h for help\n";
|
||||
exit(0);
|
||||
}
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
|
||||
$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
if($have_old && !$opt_d)
|
||||
{
|
||||
$msg = <<EDQ;
|
||||
|
||||
Ah, I see you already have installed libnet before.
|
||||
|
||||
Do you want to modify/update your configuration (y|n) ?
|
||||
EDQ
|
||||
|
||||
$opt_d = 1
|
||||
unless get_bool($msg,0);
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
This script will prompt you to enter hostnames that can be used as
|
||||
defaults for some of the modules in the libnet distribution.
|
||||
|
||||
To ensure that you do not enter an invalid hostname, I can perform a
|
||||
lookup on each hostname you enter. If your internet connection is via
|
||||
a dialup line then you may not want me to perform these lookups, as
|
||||
it will require you to be on-line.
|
||||
|
||||
Do you want me to perform hostname lookups (y|n) ?
|
||||
EDQ
|
||||
|
||||
$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
|
||||
|
||||
print <<EDQ unless $cfg{'test_exist'};
|
||||
|
||||
*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
|
||||
|
||||
OK I will not check if the hostnames you give are valid
|
||||
so be very cafeful
|
||||
|
||||
*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
|
||||
EDQ
|
||||
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
print <<EDQ;
|
||||
|
||||
The following questions all require a list of host names, separated
|
||||
with spaces. If you do not have a host available for any of the
|
||||
services, then enter a single space, followed by <CR>. To accept the
|
||||
default, hit <CR>
|
||||
|
||||
EDQ
|
||||
|
||||
$msg = 'Enter a list of available NNTP hosts :';
|
||||
|
||||
$def = $oldcfg{'nntp_hosts'} ||
|
||||
[ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
|
||||
|
||||
$cfg{'nntp_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available SMTP hosts :';
|
||||
|
||||
$def = $oldcfg{'smtp_hosts'} ||
|
||||
[ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
|
||||
|
||||
$cfg{'smtp_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available POP3 hosts :';
|
||||
|
||||
$def = $oldcfg{'pop3_hosts'} || [];
|
||||
|
||||
$cfg{'pop3_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available SNPP hosts :';
|
||||
|
||||
$def = $oldcfg{'snpp_hosts'} || [];
|
||||
|
||||
$cfg{'snpp_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available PH Hosts :' ;
|
||||
|
||||
$def = $oldcfg{'ph_hosts'} ||
|
||||
[ default_hostname('dirserv') ];
|
||||
|
||||
$cfg{'ph_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available TIME Hosts :' ;
|
||||
|
||||
$def = $oldcfg{'time_hosts'} || [];
|
||||
|
||||
$cfg{'time_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = 'Enter a list of available DAYTIME Hosts :' ;
|
||||
|
||||
$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
|
||||
|
||||
$cfg{'daytime_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
Do you have a firewall/ftp proxy between your machine and the internet
|
||||
|
||||
If you use a SOCKS firewall answer no
|
||||
|
||||
(y|n) ?
|
||||
EDQ
|
||||
|
||||
if(get_bool($msg,0)) {
|
||||
|
||||
$msg = <<'EDQ';
|
||||
What series of FTP commands do you need to send to your
|
||||
firewall to connect to an external host.
|
||||
|
||||
user/pass => external user & password
|
||||
fwuser/fwpass => firewall user & password
|
||||
|
||||
0) None
|
||||
1) -----------------------
|
||||
USER user@remote.host
|
||||
PASS pass
|
||||
2) -----------------------
|
||||
USER fwuser
|
||||
PASS fwpass
|
||||
USER user@remote.host
|
||||
PASS pass
|
||||
3) -----------------------
|
||||
USER fwuser
|
||||
PASS fwpass
|
||||
SITE remote.site
|
||||
USER user
|
||||
PASS pass
|
||||
4) -----------------------
|
||||
USER fwuser
|
||||
PASS fwpass
|
||||
OPEN remote.site
|
||||
USER user
|
||||
PASS pass
|
||||
5) -----------------------
|
||||
USER user@fwuser@remote.site
|
||||
PASS pass@fwpass
|
||||
6) -----------------------
|
||||
USER fwuser@remote.site
|
||||
PASS fwpass
|
||||
USER user
|
||||
PASS pass
|
||||
7) -----------------------
|
||||
USER user@remote.host
|
||||
PASS pass
|
||||
AUTH fwuser
|
||||
RESP fwpass
|
||||
|
||||
Choice:
|
||||
EDQ
|
||||
$def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1;
|
||||
$ans = Prompt($msg,$def);
|
||||
$cfg{'ftp_firewall_type'} = 0+$ans;
|
||||
$def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
|
||||
|
||||
$cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
|
||||
}
|
||||
else {
|
||||
delete $cfg{'ftp_firewall'};
|
||||
}
|
||||
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
if (defined $cfg{'ftp_firewall'})
|
||||
{
|
||||
print <<EDQ;
|
||||
|
||||
By default Net::FTP assumes that it only needs to use a firewall if it
|
||||
cannot resolve the name of the host given. This only works if your DNS
|
||||
system is setup to only resolve internal hostnames. If this is not the
|
||||
case and your DNS will resolve external hostnames, then another method
|
||||
is needed. Net::Config can do this if you provide the netmasks that
|
||||
describe your internal network. Each netmask should be entered in the
|
||||
form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
|
||||
|
||||
EDQ
|
||||
$def = [];
|
||||
if(ref($oldcfg{'local_netmask'}))
|
||||
{
|
||||
$def = $oldcfg{'local_netmask'};
|
||||
print "Your current netmasks are :\n\n\t",
|
||||
join("\n\t",@{$def}),"\n\n";
|
||||
}
|
||||
|
||||
print "
|
||||
Enter one netmask at each prompt, prefix with a - to remove a netmask
|
||||
from the list, enter a '*' to clear the whole list, an '=' to show the
|
||||
current list and an empty line to continue with Configure.
|
||||
|
||||
";
|
||||
|
||||
my $mask = get_netmask("netmask :",$def);
|
||||
$cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
|
||||
}
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
###$msg =<<EDQ;
|
||||
###
|
||||
###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
|
||||
###then enter a list of hostames
|
||||
###
|
||||
###Enter a list of available SOCKS hosts :
|
||||
###EDQ
|
||||
###
|
||||
###$def = $cfg{'socks_hosts'} ||
|
||||
### [ default_hostname($ENV{SOCKS5_SERVER},
|
||||
### $ENV{SOCKS_SERVER},
|
||||
### $ENV{SOCKS4_SERVER}) ];
|
||||
###
|
||||
###$cfg{'socks_hosts'} = get_host_list($msg,$def);
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
print <<EDQ;
|
||||
|
||||
Normally when FTP needs a data connection the client tells the server
|
||||
a port to connect to, and the server initiates a connection to the client.
|
||||
|
||||
Some setups, in particular firewall setups, can/do not work using this
|
||||
protocol. In these situations the client must make the connection to the
|
||||
server, this is called a passive transfer.
|
||||
EDQ
|
||||
|
||||
if (defined $cfg{'ftp_firewall'}) {
|
||||
$msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
|
||||
|
||||
$def = $oldcfg{'ftp_ext_passive'} || 0;
|
||||
|
||||
$cfg{'ftp_ext_passive'} = get_bool($msg,$def);
|
||||
|
||||
$msg = "\nShould all other FTP connections be passive (y|n) ?";
|
||||
|
||||
}
|
||||
else {
|
||||
$msg = "\nShould all FTP connections be passive (y|n) ?";
|
||||
}
|
||||
|
||||
$def = $oldcfg{'ftp_int_passive'} || 0;
|
||||
|
||||
$cfg{'ftp_int_passive'} = get_bool($msg,$def);
|
||||
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
|
||||
|
||||
$ans = Prompt("\nWhat is your local internet domain name :",$def);
|
||||
|
||||
$cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
If you specified some default hosts above, it is possible for me to
|
||||
do some basic tests when you run 'make test'
|
||||
|
||||
This will cause 'make test' to be quite a bit slower and, if your
|
||||
internet connection is via dialup, will require you to be on-line
|
||||
unless the hosts are local.
|
||||
|
||||
Do you want me to run these tests (y|n) ?
|
||||
EDQ
|
||||
|
||||
$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
$msg = <<EDQ;
|
||||
|
||||
To allow Net::FTP to be tested I will need a hostname. This host
|
||||
should allow anonymous access and have a /pub directory
|
||||
|
||||
What host can I use :
|
||||
EDQ
|
||||
|
||||
$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
|
||||
if $cfg{'test_hosts'};
|
||||
|
||||
|
||||
print "\n";
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
my $fh = IO::File->new($libnet_cfg_out, "w") or
|
||||
die "Cannot create '$libnet_cfg_out': $!";
|
||||
|
||||
print "Writing $libnet_cfg_out\n";
|
||||
|
||||
print $fh "{\n";
|
||||
|
||||
my $key;
|
||||
foreach $key (keys %cfg) {
|
||||
my $val = $cfg{$key};
|
||||
if(!defined($val)) {
|
||||
$val = "undef";
|
||||
}
|
||||
elsif(ref($val)) {
|
||||
$val = '[' . join(",",
|
||||
map {
|
||||
my $v = "undef";
|
||||
if(defined $_) {
|
||||
($v = $_) =~ s/'/\'/sog;
|
||||
$v = "'" . $v . "'";
|
||||
}
|
||||
$v;
|
||||
} @$val ) . ']';
|
||||
}
|
||||
else {
|
||||
$val =~ s/'/\'/sog;
|
||||
$val = "'" . $val . "'" if $val =~ /\D/;
|
||||
}
|
||||
print $fh "\t'",$key,"' => ",$val,",\n";
|
||||
}
|
||||
|
||||
print $fh "}\n";
|
||||
|
||||
$fh->close;
|
||||
|
||||
############################################################################
|
||||
############################################################################
|
||||
|
||||
exit 0;
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
require Mojolicious::Commands;
|
||||
Mojolicious::Commands->start_app('Mojo::HelloWorld');
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
mojo - The Mojolicious command system
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$ mojo --help
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
List and run L<Mojolicious> commands as described in
|
||||
L<Mojolicious::Commands>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Getopt::Long qw(GetOptions :config no_auto_abbrev no_ignore_case);
|
||||
|
||||
GetOptions
|
||||
'h|help' => \my $help,
|
||||
'l|listen=s' => \my @listen,
|
||||
'm|mode=s' => \$ENV{MOJO_MODE},
|
||||
'v|verbose' => \$ENV{MORBO_VERBOSE},
|
||||
'w|watch=s' => \my @watch;
|
||||
|
||||
my $app = shift;
|
||||
if ($help || !$app) {
|
||||
require Mojolicious::Command;
|
||||
die Mojolicious::Command->new->extract_usage;
|
||||
}
|
||||
|
||||
require Mojo::Server::Morbo;
|
||||
my $morbo = Mojo::Server::Morbo->new;
|
||||
$morbo->daemon->listen(\@listen) if @listen;
|
||||
$morbo->watch(\@watch) if @watch;
|
||||
$morbo->run($app);
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
morbo - Morbo HTTP and WebSocket development server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Usage: morbo [OPTIONS] [APPLICATION]
|
||||
|
||||
morbo ./script/my_app
|
||||
morbo ./myapp.pl
|
||||
morbo -m production -l https://*:443 -l http://[::]:3000 ./myapp.pl
|
||||
morbo -l 'https://*:443?cert=./server.crt&key=./server.key' ./myapp.pl
|
||||
morbo -w /usr/local/lib -w public ./myapp.pl
|
||||
|
||||
Options:
|
||||
-h, --help Show this message
|
||||
-l, --listen <location> One or more locations you want to listen on,
|
||||
defaults to the value of MOJO_LISTEN or
|
||||
"http://*:3000"
|
||||
-m, --mode <name> Operating mode for your application,
|
||||
defaults to the value of
|
||||
MOJO_MODE/PLACK_ENV or "development"
|
||||
-v, --verbose Print details about what files changed to
|
||||
STDOUT
|
||||
-w, --watch <directory/file> One or more directories and files to watch
|
||||
for changes, defaults to the application
|
||||
script as well as the "lib" and "templates"
|
||||
directories in the current working
|
||||
directory
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Start L<Mojolicious> and L<Mojolicious::Lite> applications with the
|
||||
L<Mojo::Server::Morbo> web server.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
|
||||
|
||||
=cut
|
||||
Двоичный файл не отображается.
Двоичный файл не отображается.
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,11 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if 0;
|
||||
|
||||
# This "perldoc" file was generated by "perldoc.PL"
|
||||
|
||||
require 5;
|
||||
BEGIN { $^W = 1 if $ENV{'PERLDOCDEBUG'} }
|
||||
use Pod::Perldoc;
|
||||
exit( Pod::Perldoc->run() );
|
||||
|
||||
|
|
@ -0,0 +1,390 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
# perlivp v5.22.0
|
||||
|
||||
sub usage {
|
||||
warn "@_\n" if @_;
|
||||
print << " EOUSAGE";
|
||||
Usage:
|
||||
|
||||
$0 [-p] [-v] | [-h]
|
||||
|
||||
-p Print a preface before each test telling what it will test.
|
||||
-v Verbose mode in which extra information about test results
|
||||
is printed. Test failures always print out some extra information
|
||||
regardless of whether or not this switch is set.
|
||||
-h Prints this help message.
|
||||
EOUSAGE
|
||||
exit;
|
||||
}
|
||||
|
||||
use vars qw(%opt); # allow testing with older versions (do not use our)
|
||||
|
||||
@opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
|
||||
|
||||
while ($ARGV[0] =~ /^-/) {
|
||||
$ARGV[0] =~ s/^-//;
|
||||
for my $flag (split(//,$ARGV[0])) {
|
||||
usage() if '?' =~ /\Q$flag/;
|
||||
usage() if 'h' =~ /\Q$flag/;
|
||||
usage() if 'H' =~ /\Q$flag/;
|
||||
usage("unknown flag: '$flag'") unless 'HhPpVv' =~ /\Q$flag/;
|
||||
warn "$0: '$flag' flag already set\n" if $opt{$flag}++;
|
||||
}
|
||||
shift;
|
||||
}
|
||||
|
||||
$opt{p}++ if $opt{P};
|
||||
$opt{v}++ if $opt{V};
|
||||
|
||||
my $pass__total = 0;
|
||||
my $error_total = 0;
|
||||
my $tests_total = 0;
|
||||
|
||||
my $perlpath = '/data/local/perl/bin/perl5.22.0';
|
||||
my $useithreads = '';
|
||||
|
||||
print "## Checking Perl binary via variable '\$perlpath' = $perlpath.\n" if $opt{'p'};
|
||||
|
||||
my $label = 'Executable perl binary';
|
||||
|
||||
if (-x $perlpath) {
|
||||
print "## Perl binary '$perlpath' appears executable.\n" if $opt{'v'};
|
||||
print "ok 1 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "# Perl binary '$perlpath' does not appear executable.\n";
|
||||
print "not ok 1 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking Perl version via variable '\$]'.\n" if $opt{'p'};
|
||||
|
||||
my $ivp_VERSION = "5.022000";
|
||||
|
||||
|
||||
$label = 'Perl version correct';
|
||||
if ($ivp_VERSION eq $]) {
|
||||
print "## Perl version '$]' appears installed as expected.\n" if $opt{'v'};
|
||||
print "ok 2 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
|
||||
print "not ok 2 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
# We have the right perl and version, so now reset @INC so we ignore
|
||||
# PERL5LIB and '.'
|
||||
{
|
||||
local $ENV{PERL5LIB};
|
||||
my $perl_V = qx($perlpath -V);
|
||||
$perl_V =~ s{.*\@INC:\n}{}ms;
|
||||
@INC = grep { length && $_ ne '.' } split ' ', $perl_V;
|
||||
}
|
||||
|
||||
print "## Checking roots of the Perl library directory tree via variable '\@INC'.\n" if $opt{'p'};
|
||||
|
||||
my $INC_total = 0;
|
||||
my $INC_there = 0;
|
||||
foreach (@INC) {
|
||||
next if $_ eq '.'; # skip -d test here
|
||||
if (-d $_) {
|
||||
print "## Perl \@INC directory '$_' exists.\n" if $opt{'v'};
|
||||
$INC_there++;
|
||||
}
|
||||
else {
|
||||
print "# Perl \@INC directory '$_' does not appear to exist.\n";
|
||||
}
|
||||
$INC_total++;
|
||||
}
|
||||
|
||||
$label = '@INC directoreis exist';
|
||||
if ($INC_total == $INC_there) {
|
||||
print "ok 3 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 3 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
|
||||
|
||||
my $needed_total = 0;
|
||||
my $needed_there = 0;
|
||||
foreach (qw(Config.pm ExtUtils/Installed.pm)) {
|
||||
$@ = undef;
|
||||
$needed_total++;
|
||||
eval "require \"$_\";";
|
||||
if (!$@) {
|
||||
print "## Module '$_' appears to be installed.\n" if $opt{'v'};
|
||||
$needed_there++;
|
||||
}
|
||||
else {
|
||||
print "# Needed module '$_' does not appear to be properly installed.\n";
|
||||
}
|
||||
$@ = undef;
|
||||
}
|
||||
$label = 'Modules needed for rest of perlivp exist';
|
||||
if ($needed_total == $needed_there) {
|
||||
print "ok 4 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 4 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
|
||||
|
||||
use Config;
|
||||
|
||||
my $extensions_total = 0;
|
||||
my $extensions_there = 0;
|
||||
if (defined($Config{'extensions'})) {
|
||||
my @extensions = split(/\s+/,$Config{'extensions'});
|
||||
foreach (@extensions) {
|
||||
next if ($_ eq '');
|
||||
if ( $useithreads !~ /define/i ) {
|
||||
next if ($_ eq 'threads');
|
||||
next if ($_ eq 'threads/shared');
|
||||
}
|
||||
# that's a distribution name, not a module name
|
||||
next if $_ eq 'IO/Compress';
|
||||
next if $_ eq 'Devel/DProf';
|
||||
next if $_ eq 'libnet';
|
||||
next if $_ eq 'Locale/Codes';
|
||||
next if $_ eq 'podlators';
|
||||
next if $_ eq 'perlfaq';
|
||||
# test modules
|
||||
next if $_ eq 'XS/APItest';
|
||||
next if $_ eq 'XS/Typemap';
|
||||
# VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
|
||||
# \NT> perl -e "eval \"require 'Devel/DProf.pm'\"; print $@"
|
||||
# DProf: run perl with -d to use DProf.
|
||||
# Compilation failed in require at (eval 1) line 1.
|
||||
eval " require \"$_.pm\"; ";
|
||||
if (!$@) {
|
||||
print "## Module '$_' appears to be installed.\n" if $opt{'v'};
|
||||
$extensions_there++;
|
||||
}
|
||||
else {
|
||||
print "# Required module '$_' does not appear to be properly installed.\n";
|
||||
$@ = undef;
|
||||
}
|
||||
$extensions_total++;
|
||||
}
|
||||
|
||||
# A silly name for a module (that hopefully won't ever exist).
|
||||
# Note that this test serves more as a check of the validity of the
|
||||
# actual required module tests above.
|
||||
my $unnecessary = 'bLuRfle';
|
||||
|
||||
if (!grep(/$unnecessary/, @extensions)) {
|
||||
$@ = undef;
|
||||
eval " require \"$unnecessary.pm\"; ";
|
||||
if ($@) {
|
||||
print "## Unnecessary module '$unnecessary' does not appear to be installed.\n" if $opt{'v'};
|
||||
}
|
||||
else {
|
||||
print "# Unnecessary module '$unnecessary' appears to be installed.\n";
|
||||
$extensions_there++;
|
||||
}
|
||||
}
|
||||
$@ = undef;
|
||||
}
|
||||
$label = 'All (and only) expected extensions installed';
|
||||
if ($extensions_total == $extensions_there) {
|
||||
print "ok 5 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 5 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
|
||||
print "## Checking installations of later additional extensions.\n" if $opt{'p'};
|
||||
|
||||
use ExtUtils::Installed;
|
||||
|
||||
my $installed_total = 0;
|
||||
my $installed_there = 0;
|
||||
my $version_check = 0;
|
||||
my $installed = ExtUtils::Installed -> new();
|
||||
my @modules = $installed -> modules();
|
||||
my @missing = ();
|
||||
my $version = undef;
|
||||
for (@modules) {
|
||||
$installed_total++;
|
||||
# Consider it there if it contains one or more files,
|
||||
# and has zero missing files,
|
||||
# and has a defined version
|
||||
$version = undef;
|
||||
$version = $installed -> version($_);
|
||||
if ($version) {
|
||||
print "## $_; $version\n" if $opt{'v'};
|
||||
$version_check++;
|
||||
}
|
||||
else {
|
||||
print "# $_; NO VERSION\n" if $opt{'v'};
|
||||
}
|
||||
$version = undef;
|
||||
@missing = ();
|
||||
@missing = $installed -> validate($_);
|
||||
|
||||
# .bs files are optional
|
||||
@missing = grep { ! /\.bs$/ } @missing;
|
||||
# man files are often compressed
|
||||
@missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
|
||||
|
||||
if ($#missing >= 0) {
|
||||
print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
|
||||
print '# ',join(' ',@missing),"\n";
|
||||
}
|
||||
elsif ($#missing == -1) {
|
||||
$installed_there++;
|
||||
}
|
||||
@missing = ();
|
||||
}
|
||||
$label = 'Module files correctly installed';
|
||||
if (($installed_total == $installed_there) &&
|
||||
($installed_total == $version_check)) {
|
||||
print "ok 6 $label\n";
|
||||
$pass__total++;
|
||||
}
|
||||
else {
|
||||
print "not ok 6 $label\n";
|
||||
$error_total++;
|
||||
}
|
||||
$tests_total++;
|
||||
|
||||
# Final report (rather than feed ousrselves to Test::Harness::runtests()
|
||||
# we simply format some output on our own to keep things simple and
|
||||
# easier to "fix" - at least for now.
|
||||
|
||||
if ($error_total == 0 && $tests_total) {
|
||||
print "All tests successful.\n";
|
||||
} elsif ($tests_total==0){
|
||||
die "FAILED--no tests were run for some reason.\n";
|
||||
} else {
|
||||
my $rate = 0.0;
|
||||
if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
|
||||
printf " %d/%d subtests failed, %.2f%% okay.\n",
|
||||
$error_total, $tests_total, $rate;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
perlivp - Perl Installation Verification Procedure
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<perlivp> [B<-p>] [B<-v>] [B<-h>]
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<perlivp> program is set up at Perl source code build time to test the
|
||||
Perl version it was built under. It can be used after running:
|
||||
|
||||
make install
|
||||
|
||||
(or your platform's equivalent procedure) to verify that B<perl> and its
|
||||
libraries have been installed correctly. A correct installation is verified
|
||||
by output that looks like:
|
||||
|
||||
ok 1
|
||||
ok 2
|
||||
|
||||
etc.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 5
|
||||
|
||||
=item B<-h> help
|
||||
|
||||
Prints out a brief help message.
|
||||
|
||||
=item B<-p> print preface
|
||||
|
||||
Gives a description of each test prior to performing it.
|
||||
|
||||
=item B<-v> verbose
|
||||
|
||||
Gives more detailed information about each test, after it has been performed.
|
||||
Note that any failed tests ought to print out some extra information whether
|
||||
or not -v is thrown.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over 4
|
||||
|
||||
=item * print "# Perl binary '$perlpath' does not appear executable.\n";
|
||||
|
||||
Likely to occur for a perl binary that was not properly installed.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=item * print "# Perl version '$]' installed, expected $ivp_VERSION.\n";
|
||||
|
||||
Likely to occur for a perl that was not properly installed.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=item * print "# Perl \@INC directory '$_' does not appear to exist.\n";
|
||||
|
||||
Likely to occur for a perl library tree that was not properly installed.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=item * print "# Needed module '$_' does not appear to be properly installed.\n";
|
||||
|
||||
One of the two modules that is used by perlivp was not present in the
|
||||
installation. This is a serious error since it adversely affects perlivp's
|
||||
ability to function. You may be able to correct this by performing a
|
||||
proper perl installation.
|
||||
|
||||
=item * print "# Required module '$_' does not appear to be properly installed.\n";
|
||||
|
||||
An attempt to C<eval "require $module"> failed, even though the list of
|
||||
extensions indicated that it should succeed. Correct by conducting a proper
|
||||
installation.
|
||||
|
||||
=item * print "# Unnecessary module 'bLuRfle' appears to be installed.\n";
|
||||
|
||||
This test not coming out ok could indicate that you have in fact installed
|
||||
a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
|
||||
test may give misleading results with your installation of perl. If yours
|
||||
is the latter case then please let the author know.
|
||||
|
||||
=item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
|
||||
|
||||
One or more files turned up missing according to a run of
|
||||
C<ExtUtils::Installed -E<gt> validate()> over your installation.
|
||||
Correct by conducting a proper installation.
|
||||
|
||||
=back
|
||||
|
||||
For further information on how to conduct a proper installation consult the
|
||||
INSTALL file that comes with the perl source and the README file for your
|
||||
platform.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Peter Prymmer
|
||||
|
||||
=cut
|
||||
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,321 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!./perl
|
||||
# $Id: piconv,v 2.7 2014/05/31 09:48:48 dankogai Exp $
|
||||
#
|
||||
use 5.8.0;
|
||||
use strict;
|
||||
use Encode ;
|
||||
use Encode::Alias;
|
||||
my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio);
|
||||
|
||||
use File::Basename;
|
||||
my $name = basename($0);
|
||||
|
||||
use Getopt::Long qw(:config no_ignore_case);
|
||||
|
||||
my %Opt;
|
||||
|
||||
help()
|
||||
unless
|
||||
GetOptions(\%Opt,
|
||||
'from|f=s',
|
||||
'to|t=s',
|
||||
'list|l',
|
||||
'string|s=s',
|
||||
'check|C=i',
|
||||
'c',
|
||||
'perlqq|p',
|
||||
'htmlcref',
|
||||
'xmlcref',
|
||||
'debug|D',
|
||||
'scheme|S=s',
|
||||
'resolve|r=s',
|
||||
'help',
|
||||
);
|
||||
|
||||
$Opt{help} and help();
|
||||
$Opt{list} and list_encodings();
|
||||
my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG};
|
||||
defined $Opt{resolve} and resolve_encoding($Opt{resolve});
|
||||
$Opt{from} || $Opt{to} || help();
|
||||
my $from = $Opt{from} || $locale or help("from_encoding unspecified");
|
||||
my $to = $Opt{to} || $locale or help("to_encoding unspecified");
|
||||
$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit;
|
||||
my $scheme = do {
|
||||
if (defined $Opt{scheme}) {
|
||||
if (!exists $Scheme{$Opt{scheme}}) {
|
||||
warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n";
|
||||
'from_to';
|
||||
} else {
|
||||
$Opt{scheme};
|
||||
}
|
||||
} else {
|
||||
'from_to';
|
||||
}
|
||||
};
|
||||
|
||||
$Opt{check} ||= $Opt{c};
|
||||
$Opt{perlqq} and $Opt{check} = Encode::PERLQQ;
|
||||
$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF;
|
||||
$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF;
|
||||
|
||||
my $efrom = Encode->getEncoding($from) || die "Unknown encoding '$from'";
|
||||
my $eto = Encode->getEncoding($to) || die "Unknown encoding '$to'";
|
||||
|
||||
my $cfrom = $efrom->name;
|
||||
my $cto = $eto->name;
|
||||
|
||||
if ($Opt{debug}){
|
||||
print <<"EOT";
|
||||
Scheme: $scheme
|
||||
From: $from => $cfrom
|
||||
To: $to => $cto
|
||||
EOT
|
||||
}
|
||||
|
||||
my %use_bom =
|
||||
map { $_ => 1 } qw/UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE/;
|
||||
|
||||
# we do not use <> (or ARGV) for the sake of binmode()
|
||||
@ARGV or push @ARGV, \*STDIN;
|
||||
|
||||
unless ( $scheme eq 'perlio' ) {
|
||||
binmode STDOUT;
|
||||
my $need2slurp = $use_bom{ $eto } || $use_bom{ $efrom };
|
||||
for my $argv (@ARGV) {
|
||||
my $ifh = ref $argv ? $argv : undef;
|
||||
$ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
|
||||
$ifh or open $ifh, "<", $argv or next;
|
||||
binmode $ifh;
|
||||
if ( $scheme eq 'from_to' ) { # default
|
||||
if ($need2slurp){
|
||||
local $/;
|
||||
$_ = <$ifh>;
|
||||
Encode::from_to( $_, $from, $to, $Opt{check} );
|
||||
print;
|
||||
}else{
|
||||
while (<$ifh>) {
|
||||
Encode::from_to( $_, $from, $to, $Opt{check} );
|
||||
print;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $scheme eq 'decode_encode' ) { # step-by-step
|
||||
if ($need2slurp){
|
||||
local $/;
|
||||
$_ = <$ifh>;
|
||||
my $decoded = decode( $from, $_, $Opt{check} );
|
||||
my $encoded = encode( $to, $decoded );
|
||||
print $encoded;
|
||||
}else{
|
||||
while (<$ifh>) {
|
||||
my $decoded = decode( $from, $_, $Opt{check} );
|
||||
my $encoded = encode( $to, $decoded );
|
||||
print $encoded;
|
||||
}
|
||||
}
|
||||
}
|
||||
else { # won't reach
|
||||
die "$name: unknown scheme: $scheme";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
|
||||
# NI-S favorite
|
||||
binmode STDOUT => "raw:encoding($to)";
|
||||
for my $argv (@ARGV) {
|
||||
my $ifh = ref $argv ? $argv : undef;
|
||||
$ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
|
||||
$ifh or open $ifh, "<", $argv or next;
|
||||
binmode $ifh => "raw:encoding($from)";
|
||||
print while (<$ifh>);
|
||||
}
|
||||
}
|
||||
|
||||
sub list_encodings {
|
||||
print join( "\n", Encode->encodings(":all") ), "\n";
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub resolve_encoding {
|
||||
if ( my $alias = Encode::resolve_alias( $_[0] ) ) {
|
||||
print $alias, "\n";
|
||||
exit 0;
|
||||
}
|
||||
else {
|
||||
warn "$name: $_[0] is not known to Encode\n";
|
||||
exit 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub help {
|
||||
my $message = shift;
|
||||
$message and print STDERR "$name error: $message\n";
|
||||
print STDERR <<"EOT";
|
||||
$name [-f from_encoding] [-t to_encoding]
|
||||
[-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme]
|
||||
[-s string|file...]
|
||||
$name -l
|
||||
$name -r encoding_alias
|
||||
$name -h
|
||||
Common options:
|
||||
-l,--list
|
||||
lists all available encodings
|
||||
-r,--resolve encoding_alias
|
||||
resolve encoding to its (Encode) canonical name
|
||||
-f,--from from_encoding
|
||||
when omitted, the current locale will be used
|
||||
-t,--to to_encoding
|
||||
when omitted, the current locale will be used
|
||||
-s,--string string
|
||||
"string" will be the input instead of STDIN or files
|
||||
The following are mainly of interest to Encode hackers:
|
||||
-C N | -c check the validity of the input
|
||||
-D,--debug show debug information
|
||||
-S,--scheme scheme use the scheme for conversion
|
||||
Those are handy when you can only see ASCII characters:
|
||||
-p,--perlqq transliterate characters missing in encoding to \\x{HHHH}
|
||||
where HHHH is the hexadecimal Unicode code point
|
||||
--htmlcref transliterate characters missing in encoding to &#NNN;
|
||||
where NNN is the decimal Unicode code point
|
||||
--xmlcref transliterate characters missing in encoding to &#xHHHH;
|
||||
where HHHH is the hexadecimal Unicode code point
|
||||
|
||||
EOT
|
||||
exit;
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
piconv -- iconv(1), reinvented in perl
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
piconv [-f from_encoding] [-t to_encoding]
|
||||
[-p|--perlqq|--htmlcref|--xmlcref] [-C N|-c] [-D] [-S scheme]
|
||||
[-s string|file...]
|
||||
piconv -l
|
||||
piconv -r encoding_alias
|
||||
piconv -h
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<piconv> is perl version of B<iconv>, a character encoding converter
|
||||
widely available for various Unixen today. This script was primarily
|
||||
a technology demonstrator for Perl 5.8.0, but you can use piconv in the
|
||||
place of iconv for virtually any case.
|
||||
|
||||
piconv converts the character encoding of either STDIN or files
|
||||
specified in the argument and prints out to STDOUT.
|
||||
|
||||
Here is the list of options. Some options can be in short format (-f)
|
||||
or long (--from) one.
|
||||
|
||||
=over 4
|
||||
|
||||
=item -f,--from I<from_encoding>
|
||||
|
||||
Specifies the encoding you are converting from. Unlike B<iconv>,
|
||||
this option can be omitted. In such cases, the current locale is used.
|
||||
|
||||
=item -t,--to I<to_encoding>
|
||||
|
||||
Specifies the encoding you are converting to. Unlike B<iconv>,
|
||||
this option can be omitted. In such cases, the current locale is used.
|
||||
|
||||
Therefore, when both -f and -t are omitted, B<piconv> just acts
|
||||
like B<cat>.
|
||||
|
||||
=item -s,--string I<string>
|
||||
|
||||
uses I<string> instead of file for the source of text.
|
||||
|
||||
=item -l,--list
|
||||
|
||||
Lists all available encodings, one per line, in case-insensitive
|
||||
order. Note that only the canonical names are listed; many aliases
|
||||
exist. For example, the names are case-insensitive, and many standard
|
||||
and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850"
|
||||
instead of "cp850", or "winlatin1" for "cp1252". See L<Encode::Supported>
|
||||
for a full discussion.
|
||||
|
||||
=item -r,--resolve I<encoding_alias>
|
||||
|
||||
Resolve I<encoding_alias> to Encode canonical encoding name.
|
||||
|
||||
=item -C,--check I<N>
|
||||
|
||||
Check the validity of the stream if I<N> = 1. When I<N> = -1, something
|
||||
interesting happens when it encounters an invalid character.
|
||||
|
||||
=item -c
|
||||
|
||||
Same as C<-C 1>.
|
||||
|
||||
=item -p,--perlqq
|
||||
|
||||
Transliterate characters missing in encoding to \x{HHHH} where HHHH is the
|
||||
hexadecimal Unicode code point.
|
||||
|
||||
=item --htmlcref
|
||||
|
||||
Transliterate characters missing in encoding to &#NNN; where NNN is the
|
||||
decimal Unicode code point.
|
||||
|
||||
=item --xmlcref
|
||||
|
||||
Transliterate characters missing in encoding to &#xHHHH; where HHHH is the
|
||||
hexadecimal Unicode code point.
|
||||
|
||||
=item -h,--help
|
||||
|
||||
Show usage.
|
||||
|
||||
=item -D,--debug
|
||||
|
||||
Invokes debugging mode. Primarily for Encode hackers.
|
||||
|
||||
=item -S,--scheme I<scheme>
|
||||
|
||||
Selects which scheme is to be used for conversion. Available schemes
|
||||
are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item from_to
|
||||
|
||||
Uses Encode::from_to for conversion. This is the default.
|
||||
|
||||
=item decode_encode
|
||||
|
||||
Input strings are decode()d then encode()d. A straight two-step
|
||||
implementation.
|
||||
|
||||
=item perlio
|
||||
|
||||
The new perlIO layer is used. NI-S' favorite.
|
||||
|
||||
You should use this option if you are using UTF-16 and others which
|
||||
linefeed is not $/.
|
||||
|
||||
=back
|
||||
|
||||
Like the I<-D> option, this is also for Encode hackers.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<iconv(1)>
|
||||
L<locale(3)>
|
||||
L<Encode>
|
||||
L<Encode::Supported>
|
||||
L<Encode::Alias>
|
||||
L<PerlIO>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,378 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<pl2pm> F<files>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl
|
||||
library files to Perl5-style library modules. Usually, your old .pl
|
||||
file will still work fine and you should only use this tool if you
|
||||
plan to update your library to use some of the newer Perl 5 features,
|
||||
such as AutoLoading.
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
It's just a first step, but it's usually a good first step.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Larry Wall <larry@wall.org>
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %keyword = ();
|
||||
|
||||
while (<DATA>) {
|
||||
chomp;
|
||||
$keyword{$_} = 1;
|
||||
}
|
||||
|
||||
local $/;
|
||||
|
||||
while (<>) {
|
||||
my $newname = $ARGV;
|
||||
$newname =~ s/\.pl$/.pm/ || next;
|
||||
$newname =~ s#(.*/)?(\w+)#$1\u$2#;
|
||||
if (-f $newname) {
|
||||
warn "Won't overwrite existing $newname\n";
|
||||
next;
|
||||
}
|
||||
my $oldpack = $2;
|
||||
my $newpack = "\u$2";
|
||||
my @export = ();
|
||||
|
||||
s/\bstd(in|out|err)\b/\U$&/g;
|
||||
s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
|
||||
if (/sub\s+\w+'/) {
|
||||
@export = m/sub\s+\w+'(\w+)/g;
|
||||
s/(sub\s+)main'(\w+)/$1$2/g;
|
||||
}
|
||||
else {
|
||||
@export = m/sub\s+([A-Za-z]\w*)/g;
|
||||
}
|
||||
my @export_ok = grep($keyword{$_}, @export);
|
||||
@export = grep(!$keyword{$_}, @export);
|
||||
|
||||
my %export = ();
|
||||
@export{@export} = (1) x @export;
|
||||
|
||||
s/(^\s*);#/$1#/g;
|
||||
s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
|
||||
s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
|
||||
s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
|
||||
s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
|
||||
if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
|
||||
s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
|
||||
s/\$\[\s*\+\s*//g;
|
||||
s/\s*\+\s*\$\[//g;
|
||||
s/\$\[/0/g;
|
||||
}
|
||||
s/open\s+(\w+)/open($1)/g;
|
||||
|
||||
my $export_ok = '';
|
||||
my $carp ='';
|
||||
|
||||
|
||||
if (s/\bdie\b/croak/g) {
|
||||
$carp = "use Carp;\n";
|
||||
s/croak "([^"]*)\\n"/croak "$1"/g;
|
||||
}
|
||||
|
||||
if (@export_ok) {
|
||||
$export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
|
||||
}
|
||||
|
||||
if ( open(PM, ">$newname") ) {
|
||||
print PM <<"END";
|
||||
package $newpack;
|
||||
use 5.006;
|
||||
require Exporter;
|
||||
$carp
|
||||
\@ISA = qw(Exporter);
|
||||
\@EXPORT = qw(@export);
|
||||
$export_ok
|
||||
$_
|
||||
END
|
||||
}
|
||||
else {
|
||||
warn "Can't create $newname: $!\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub xlate {
|
||||
my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
|
||||
|
||||
my $xlated ;
|
||||
if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
|
||||
$xlated = "${pack}'$ident";
|
||||
}
|
||||
elsif ($pack eq '' || $pack eq 'main') {
|
||||
if ($export->{$ident}) {
|
||||
$xlated = "$prefix$ident";
|
||||
}
|
||||
else {
|
||||
$xlated = "$prefix${pack}::$ident";
|
||||
}
|
||||
}
|
||||
elsif ($pack eq $oldpack) {
|
||||
$xlated = "$prefix${newpack}::$ident";
|
||||
}
|
||||
else {
|
||||
$xlated = "$prefix${pack}::$ident";
|
||||
}
|
||||
|
||||
return $xlated;
|
||||
}
|
||||
__END__
|
||||
AUTOLOAD
|
||||
BEGIN
|
||||
CHECK
|
||||
CORE
|
||||
DESTROY
|
||||
END
|
||||
INIT
|
||||
UNITCHECK
|
||||
abs
|
||||
accept
|
||||
alarm
|
||||
and
|
||||
atan2
|
||||
bind
|
||||
binmode
|
||||
bless
|
||||
caller
|
||||
chdir
|
||||
chmod
|
||||
chomp
|
||||
chop
|
||||
chown
|
||||
chr
|
||||
chroot
|
||||
close
|
||||
closedir
|
||||
cmp
|
||||
connect
|
||||
continue
|
||||
cos
|
||||
crypt
|
||||
dbmclose
|
||||
dbmopen
|
||||
defined
|
||||
delete
|
||||
die
|
||||
do
|
||||
dump
|
||||
each
|
||||
else
|
||||
elsif
|
||||
endgrent
|
||||
endhostent
|
||||
endnetent
|
||||
endprotoent
|
||||
endpwent
|
||||
endservent
|
||||
eof
|
||||
eq
|
||||
eval
|
||||
exec
|
||||
exists
|
||||
exit
|
||||
exp
|
||||
fcntl
|
||||
fileno
|
||||
flock
|
||||
for
|
||||
foreach
|
||||
fork
|
||||
format
|
||||
formline
|
||||
ge
|
||||
getc
|
||||
getgrent
|
||||
getgrgid
|
||||
getgrnam
|
||||
gethostbyaddr
|
||||
gethostbyname
|
||||
gethostent
|
||||
getlogin
|
||||
getnetbyaddr
|
||||
getnetbyname
|
||||
getnetent
|
||||
getpeername
|
||||
getpgrp
|
||||
getppid
|
||||
getpriority
|
||||
getprotobyname
|
||||
getprotobynumber
|
||||
getprotoent
|
||||
getpwent
|
||||
getpwnam
|
||||
getpwuid
|
||||
getservbyname
|
||||
getservbyport
|
||||
getservent
|
||||
getsockname
|
||||
getsockopt
|
||||
glob
|
||||
gmtime
|
||||
goto
|
||||
grep
|
||||
gt
|
||||
hex
|
||||
if
|
||||
index
|
||||
int
|
||||
ioctl
|
||||
join
|
||||
keys
|
||||
kill
|
||||
last
|
||||
lc
|
||||
lcfirst
|
||||
le
|
||||
length
|
||||
link
|
||||
listen
|
||||
local
|
||||
localtime
|
||||
lock
|
||||
log
|
||||
lstat
|
||||
lt
|
||||
m
|
||||
map
|
||||
mkdir
|
||||
msgctl
|
||||
msgget
|
||||
msgrcv
|
||||
msgsnd
|
||||
my
|
||||
ne
|
||||
next
|
||||
no
|
||||
not
|
||||
oct
|
||||
open
|
||||
opendir
|
||||
or
|
||||
ord
|
||||
our
|
||||
pack
|
||||
package
|
||||
pipe
|
||||
pop
|
||||
pos
|
||||
print
|
||||
printf
|
||||
prototype
|
||||
push
|
||||
q
|
||||
qq
|
||||
qr
|
||||
quotemeta
|
||||
qw
|
||||
qx
|
||||
rand
|
||||
read
|
||||
readdir
|
||||
readline
|
||||
readlink
|
||||
readpipe
|
||||
recv
|
||||
redo
|
||||
ref
|
||||
rename
|
||||
require
|
||||
reset
|
||||
return
|
||||
reverse
|
||||
rewinddir
|
||||
rindex
|
||||
rmdir
|
||||
s
|
||||
scalar
|
||||
seek
|
||||
seekdir
|
||||
select
|
||||
semctl
|
||||
semget
|
||||
semop
|
||||
send
|
||||
setgrent
|
||||
sethostent
|
||||
setnetent
|
||||
setpgrp
|
||||
setpriority
|
||||
setprotoent
|
||||
setpwent
|
||||
setservent
|
||||
setsockopt
|
||||
shift
|
||||
shmctl
|
||||
shmget
|
||||
shmread
|
||||
shmwrite
|
||||
shutdown
|
||||
sin
|
||||
sleep
|
||||
socket
|
||||
socketpair
|
||||
sort
|
||||
splice
|
||||
split
|
||||
sprintf
|
||||
sqrt
|
||||
srand
|
||||
stat
|
||||
study
|
||||
sub
|
||||
substr
|
||||
symlink
|
||||
syscall
|
||||
sysopen
|
||||
sysread
|
||||
sysseek
|
||||
system
|
||||
syswrite
|
||||
tell
|
||||
telldir
|
||||
tie
|
||||
tied
|
||||
time
|
||||
times
|
||||
tr
|
||||
truncate
|
||||
uc
|
||||
ucfirst
|
||||
umask
|
||||
undef
|
||||
unless
|
||||
unlink
|
||||
unpack
|
||||
unshift
|
||||
untie
|
||||
until
|
||||
use
|
||||
utime
|
||||
values
|
||||
vec
|
||||
wait
|
||||
waitpid
|
||||
wantarray
|
||||
warn
|
||||
while
|
||||
write
|
||||
x
|
||||
xor
|
||||
y
|
||||
|
|
@ -0,0 +1,224 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2html - convert .pod files to .html files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2html --help --htmldir=<name> --htmlroot=<URL>
|
||||
--infile=<name> --outfile=<name>
|
||||
--podpath=<name>:...:<name> --podroot=<name>
|
||||
--cachedir=<name> --flush --recurse --norecurse
|
||||
--quiet --noquiet --verbose --noverbose
|
||||
--index --noindex --backlink --nobacklink
|
||||
--header --noheader --poderrors --nopoderrors
|
||||
--css=<URL> --title=<name>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Converts files from pod format (see L<perlpod>) to HTML format.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
pod2html takes the following arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item help
|
||||
|
||||
--help
|
||||
|
||||
Displays the usage message.
|
||||
|
||||
=item htmldir
|
||||
|
||||
--htmldir=name
|
||||
|
||||
Sets the directory to which all cross references in the resulting HTML file
|
||||
will be relative. Not passing this causes all links to be absolute since this
|
||||
is the value that tells Pod::Html the root of the documentation tree.
|
||||
|
||||
Do not use this and --htmlroot in the same call to pod2html; they are mutually
|
||||
exclusive.
|
||||
|
||||
=item htmlroot
|
||||
|
||||
--htmlroot=URL
|
||||
|
||||
Sets the base URL for the HTML files. When cross-references are made, the
|
||||
HTML root is prepended to the URL.
|
||||
|
||||
Do not use this if relative links are desired: use --htmldir instead.
|
||||
|
||||
Do not pass both this and --htmldir to pod2html; they are mutually exclusive.
|
||||
|
||||
=item infile
|
||||
|
||||
--infile=name
|
||||
|
||||
Specify the pod file to convert. Input is taken from STDIN if no
|
||||
infile is specified.
|
||||
|
||||
=item outfile
|
||||
|
||||
--outfile=name
|
||||
|
||||
Specify the HTML file to create. Output goes to STDOUT if no outfile
|
||||
is specified.
|
||||
|
||||
=item podroot
|
||||
|
||||
--podroot=name
|
||||
|
||||
Specify the base directory for finding library pods.
|
||||
|
||||
=item podpath
|
||||
|
||||
--podpath=name:...:name
|
||||
|
||||
Specify which subdirectories of the podroot contain pod files whose
|
||||
HTML converted forms can be linked-to in cross-references.
|
||||
|
||||
=item cachedir
|
||||
|
||||
--cachedir=name
|
||||
|
||||
Specify which directory is used for storing cache. Default directory is the
|
||||
current working directory.
|
||||
|
||||
=item flush
|
||||
|
||||
--flush
|
||||
|
||||
Flush the cache.
|
||||
|
||||
=item backlink
|
||||
|
||||
--backlink
|
||||
|
||||
Turn =head1 directives into links pointing to the top of the HTML file.
|
||||
|
||||
=item nobacklink
|
||||
|
||||
--nobacklink
|
||||
|
||||
Do not turn =head1 directives into links pointing to the top of the HTML file
|
||||
(default behaviour).
|
||||
|
||||
=item header
|
||||
|
||||
--header
|
||||
|
||||
Create header and footer blocks containing the text of the "NAME" section.
|
||||
|
||||
=item noheader
|
||||
|
||||
--noheader
|
||||
|
||||
Do not create header and footer blocks containing the text of the "NAME"
|
||||
section (default behaviour).
|
||||
|
||||
=item poderrors
|
||||
|
||||
--poderrors
|
||||
|
||||
Include a "POD ERRORS" section in the outfile if there were any POD errors in
|
||||
the infile (default behaviour).
|
||||
|
||||
=item nopoderrors
|
||||
|
||||
--nopoderrors
|
||||
|
||||
Do not include a "POD ERRORS" section in the outfile if there were any POD
|
||||
errors in the infile.
|
||||
|
||||
=item index
|
||||
|
||||
--index
|
||||
|
||||
Generate an index at the top of the HTML file (default behaviour).
|
||||
|
||||
=item noindex
|
||||
|
||||
--noindex
|
||||
|
||||
Do not generate an index at the top of the HTML file.
|
||||
|
||||
|
||||
=item recurse
|
||||
|
||||
--recurse
|
||||
|
||||
Recurse into subdirectories specified in podpath (default behaviour).
|
||||
|
||||
=item norecurse
|
||||
|
||||
--norecurse
|
||||
|
||||
Do not recurse into subdirectories specified in podpath.
|
||||
|
||||
=item css
|
||||
|
||||
--css=URL
|
||||
|
||||
Specify the URL of cascading style sheet to link from resulting HTML file.
|
||||
Default is none style sheet.
|
||||
|
||||
=item title
|
||||
|
||||
--title=title
|
||||
|
||||
Specify the title of the resulting HTML file.
|
||||
|
||||
=item quiet
|
||||
|
||||
--quiet
|
||||
|
||||
Don't display mostly harmless warning messages.
|
||||
|
||||
=item noquiet
|
||||
|
||||
--noquiet
|
||||
|
||||
Display mostly harmless warning messages (default behaviour). But this is not
|
||||
the same as "verbose" mode.
|
||||
|
||||
=item verbose
|
||||
|
||||
--verbose
|
||||
|
||||
Display progress messages.
|
||||
|
||||
=item noverbose
|
||||
|
||||
--noverbose
|
||||
|
||||
Do not display progress messages (default behaviour).
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
See L<Pod::Html> for a list of known bugs in the translator.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlpod>, L<Pod::Html>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This program is distributed under the Artistic License.
|
||||
|
||||
=cut
|
||||
|
||||
use Pod::Html;
|
||||
|
||||
pod2html @ARGV;
|
||||
|
|
@ -0,0 +1,359 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
# pod2man -- Convert POD data to formatted *roff input.
|
||||
#
|
||||
# Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013
|
||||
# Russ Allbery <rra@stanford.edu>
|
||||
#
|
||||
# This program is free software; you may redistribute it and/or modify it
|
||||
# under the same terms as Perl itself.
|
||||
|
||||
require 5.004;
|
||||
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Pod::Man ();
|
||||
use Pod::Usage qw(pod2usage);
|
||||
|
||||
use strict;
|
||||
|
||||
# Clean up $0 for error reporting.
|
||||
$0 =~ s%.*/%%;
|
||||
|
||||
# Insert -- into @ARGV before any single dash argument to hide it from
|
||||
# Getopt::Long; we want to interpret it as meaning stdin.
|
||||
my $stdin;
|
||||
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
|
||||
|
||||
# Parse our options, trying to retain backward compatibility with pod2man but
|
||||
# allowing short forms as well. --lax is currently ignored.
|
||||
my %options;
|
||||
Getopt::Long::config ('bundling_override');
|
||||
GetOptions (\%options, 'center|c=s', 'date|d=s', 'errors=s', 'fixed=s',
|
||||
'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'help|h',
|
||||
'lax|l', 'name|n=s', 'nourls', 'official|o', 'quotes|q=s',
|
||||
'release|r:s', 'section|s=s', 'stderr', 'verbose|v', 'utf8|u')
|
||||
or exit 1;
|
||||
pod2usage (0) if $options{help};
|
||||
|
||||
# Official sets --center, but don't override things explicitly set.
|
||||
if ($options{official} && !defined $options{center}) {
|
||||
$options{center} = 'Perl Programmers Reference Guide';
|
||||
}
|
||||
|
||||
# Verbose is only our flag, not a Pod::Man flag.
|
||||
my $verbose = $options{verbose};
|
||||
delete $options{verbose};
|
||||
|
||||
# This isn't a valid Pod::Man option and is only accepted for backward
|
||||
# compatibility.
|
||||
delete $options{lax};
|
||||
|
||||
# If neither stderr nor errors is set, default to errors = die.
|
||||
if (!defined $options{stderr} && !defined $options{errors}) {
|
||||
$options{errors} = 'die';
|
||||
}
|
||||
|
||||
# Initialize and run the formatter, pulling a pair of input and output off at
|
||||
# a time. For each file, we check whether the document was completely empty
|
||||
# and, if so, will remove the created file and exit with a non-zero exit
|
||||
# status.
|
||||
my $parser = Pod::Man->new (%options);
|
||||
my $status = 0;
|
||||
my @files;
|
||||
do {
|
||||
@files = splice (@ARGV, 0, 2);
|
||||
print " $files[1]\n" if $verbose;
|
||||
$parser->parse_from_file (@files);
|
||||
if ($parser->{CONTENTLESS}) {
|
||||
$status = 1;
|
||||
warn "$0: unable to format $files[0]\n";
|
||||
if (defined ($files[1]) and $files[1] ne '-') {
|
||||
unlink $files[1] unless (-s $files[1]);
|
||||
}
|
||||
}
|
||||
} while (@ARGV);
|
||||
exit $status;
|
||||
|
||||
__END__
|
||||
|
||||
=for stopwords
|
||||
en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris
|
||||
URL troff troff-specific formatters uppercased Christiansen --nourls
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2man - Convert POD data to formatted *roff input
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2man [B<--center>=I<string>] [B<--date>=I<string>] [B<--errors>=I<style>]
|
||||
[B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
|
||||
[B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--nourls>]
|
||||
[B<--official>] [B<--quotes>=I<quotes>] [B<--release>[=I<version>]]
|
||||
[B<--section>=I<manext>] [B<--stderr>] [B<--utf8>] [B<--verbose>]
|
||||
[I<input> [I<output>] ...]
|
||||
|
||||
pod2man B<--help>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2man> is a front-end for Pod::Man, using it to generate *roff input
|
||||
from POD source. The resulting *roff code is suitable for display on a
|
||||
terminal using nroff(1), normally via man(1), or printing using troff(1).
|
||||
|
||||
I<input> is the file to read for POD source (the POD can be embedded in
|
||||
code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
|
||||
given, is the file to which to write the formatted output. If I<output>
|
||||
isn't given, the formatted output is written to C<STDOUT>. Several POD
|
||||
files can be processed in the same B<pod2man> invocation (saving module
|
||||
load and compile times) by providing multiple pairs of I<input> and
|
||||
I<output> files on the command line.
|
||||
|
||||
B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can
|
||||
be used to set the headers and footers to use; if not given, Pod::Man will
|
||||
assume various defaults. See below or L<Pod::Man> for details.
|
||||
|
||||
B<pod2man> assumes that your *roff formatters have a fixed-width font
|
||||
named C<CW>. If yours is called something else (like C<CR>), use
|
||||
B<--fixed> to specify it. This generally only matters for troff output
|
||||
for printing. Similarly, you can set the fonts used for bold, italic, and
|
||||
bold italic fixed-width output.
|
||||
|
||||
Besides the obvious pod conversions, Pod::Man, and therefore pod2man also
|
||||
takes care of formatting func(), func(n), and simple variable references
|
||||
like $foo or @bar so you don't have to use code escapes for them; complex
|
||||
expressions like C<$fred{'stuff'}> will still need to be escaped, though.
|
||||
It also translates dashes that aren't used as hyphens into en dashes, makes
|
||||
long dashes--like this--into proper em dashes, fixes "paired quotes," and
|
||||
takes care of several other troff-specific tweaks. See L<Pod::Man> for
|
||||
complete information.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<-c> I<string>, B<--center>=I<string>
|
||||
|
||||
Sets the centered page header to I<string>. The default is "User
|
||||
Contributed Perl Documentation", but also see B<--official> below.
|
||||
|
||||
=item B<-d> I<string>, B<--date>=I<string>
|
||||
|
||||
Set the left-hand footer string to this value. By default, the modification
|
||||
date of the input file will be used, or the current date if input comes from
|
||||
C<STDIN>.
|
||||
|
||||
=item B<-errors>=I<style>
|
||||
|
||||
Set the error handling style. C<die> says to throw an exception on any
|
||||
POD formatting error. C<stderr> says to report errors on standard error,
|
||||
but not to throw an exception. C<pod> says to include a POD ERRORS
|
||||
section in the resulting documentation summarizing the errors. C<none>
|
||||
ignores POD errors entirely, as much as possible.
|
||||
|
||||
The default is C<die>.
|
||||
|
||||
=item B<--fixed>=I<font>
|
||||
|
||||
The fixed-width font to use for verbatim text and code. Defaults to
|
||||
C<CW>. Some systems may want C<CR> instead. Only matters for troff(1)
|
||||
output.
|
||||
|
||||
=item B<--fixedbold>=I<font>
|
||||
|
||||
Bold version of the fixed-width font. Defaults to C<CB>. Only matters
|
||||
for troff(1) output.
|
||||
|
||||
=item B<--fixeditalic>=I<font>
|
||||
|
||||
Italic version of the fixed-width font (actually, something of a misnomer,
|
||||
since most fixed-width fonts only have an oblique version, not an italic
|
||||
version). Defaults to C<CI>. Only matters for troff(1) output.
|
||||
|
||||
=item B<--fixedbolditalic>=I<font>
|
||||
|
||||
Bold italic (probably actually oblique) version of the fixed-width font.
|
||||
Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
|
||||
systems (such as Solaris) have this font available as C<CX>. Only matters
|
||||
for troff(1) output.
|
||||
|
||||
=item B<-h>, B<--help>
|
||||
|
||||
Print out usage information.
|
||||
|
||||
=item B<-l>, B<--lax>
|
||||
|
||||
No longer used. B<pod2man> used to check its input for validity as a
|
||||
manual page, but this should now be done by L<podchecker(1)> instead.
|
||||
Accepted for backward compatibility; this option no longer does anything.
|
||||
|
||||
=item B<-n> I<name>, B<--name>=I<name>
|
||||
|
||||
Set the name of the manual page to I<name>. Without this option, the manual
|
||||
name is set to the uppercased base name of the file being converted unless
|
||||
the manual section is 3, in which case the path is parsed to see if it is a
|
||||
Perl module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted
|
||||
into a name like C<Pod::Man>. This option, if given, overrides any
|
||||
automatic determination of the name.
|
||||
|
||||
Note that this option is probably not useful when converting multiple POD
|
||||
files at once. The convention for Unix man pages for commands is for the
|
||||
man page title to be in all-uppercase even if the command isn't.
|
||||
|
||||
=item B<--nourls>
|
||||
|
||||
Normally, LZ<><> formatting codes with a URL but anchor text are formatted
|
||||
to show both the anchor text and the URL. In other words:
|
||||
|
||||
L<foo|http://example.com/>
|
||||
|
||||
is formatted as:
|
||||
|
||||
foo <http://example.com/>
|
||||
|
||||
This flag, if given, suppresses the URL when anchor text is given, so this
|
||||
example would be formatted as just C<foo>. This can produce less
|
||||
cluttered output in cases where the URLs are not particularly important.
|
||||
|
||||
=item B<-o>, B<--official>
|
||||
|
||||
Set the default header to indicate that this page is part of the standard
|
||||
Perl release, if B<--center> is not also given.
|
||||
|
||||
=item B<-q> I<quotes>, B<--quotes>=I<quotes>
|
||||
|
||||
Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
|
||||
I<quotes> is a single character, it is used as both the left and right
|
||||
quote; if I<quotes> is two characters, the first character is used as the
|
||||
left quote and the second as the right quoted; and if I<quotes> is four
|
||||
characters, the first two are used as the left quote and the second two as
|
||||
the right quote.
|
||||
|
||||
I<quotes> may also be set to the special value C<none>, in which case no
|
||||
quote marks are added around CE<lt>> text (but the font is still changed for
|
||||
troff output).
|
||||
|
||||
=item B<-r>, B<--release>
|
||||
|
||||
Set the centered footer. By default, this is the version of Perl you run
|
||||
B<pod2man> under. Note that some system an macro sets assume that the
|
||||
centered footer will be a modification date and will prepend something like
|
||||
"Last modified: "; if this is the case, you may want to set B<--release> to
|
||||
the last modified date and B<--date> to the version number.
|
||||
|
||||
=item B<-s>, B<--section>
|
||||
|
||||
Set the section for the C<.TH> macro. The standard section numbering
|
||||
convention is to use 1 for user commands, 2 for system calls, 3 for
|
||||
functions, 4 for devices, 5 for file formats, 6 for games, 7 for
|
||||
miscellaneous information, and 8 for administrator commands. There is a lot
|
||||
of variation here, however; some systems (like Solaris) use 4 for file
|
||||
formats, 5 for miscellaneous information, and 7 for devices. Still others
|
||||
use 1m instead of 8, or some mix of both. About the only section numbers
|
||||
that are reliably consistent are 1, 2, and 3.
|
||||
|
||||
By default, section 1 will be used unless the file ends in C<.pm>, in
|
||||
which case section 3 will be selected.
|
||||
|
||||
=item B<--stderr>
|
||||
|
||||
By default, B<pod2man> dies if any errors are detected in the POD input.
|
||||
If B<--stderr> is given and no B<--errors> flag is present, errors are
|
||||
sent to standard error, but B<pod2man> does not abort. This is equivalent
|
||||
to C<--errors=stderr> and is supported for backward compatibility.
|
||||
|
||||
=item B<-u>, B<--utf8>
|
||||
|
||||
By default, B<pod2man> produces the most conservative possible *roff
|
||||
output to try to ensure that it will work with as many different *roff
|
||||
implementations as possible. Many *roff implementations cannot handle
|
||||
non-ASCII characters, so this means all non-ASCII characters are converted
|
||||
either to a *roff escape sequence that tries to create a properly accented
|
||||
character (at least for troff output) or to C<X>.
|
||||
|
||||
This option says to instead output literal UTF-8 characters. If your
|
||||
*roff implementation can handle it, this is the best output format to use
|
||||
and avoids corruption of documents containing non-ASCII characters.
|
||||
However, be warned that *roff source with literal UTF-8 characters is not
|
||||
supported by many implementations and may even result in segfaults and
|
||||
other bad behavior.
|
||||
|
||||
Be aware that, when using this option, the input encoding of your POD
|
||||
source must be properly declared unless it is US-ASCII or Latin-1. POD
|
||||
input without an C<=encoding> command will be assumed to be in Latin-1,
|
||||
and if it's actually in UTF-8, the output will be double-encoded. See
|
||||
L<perlpod(1)> for more information on the C<=encoding> command.
|
||||
|
||||
=item B<-v>, B<--verbose>
|
||||
|
||||
Print out the name of each output file as it is being generated.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT STATUS
|
||||
|
||||
As long as all documents processed result in some output, even if that
|
||||
output includes errata (a C<POD ERRORS> section generated with
|
||||
C<--errors=pod>), B<pod2man> will exit with status 0. If any of the
|
||||
documents being processed do not result in an output document, B<pod2man>
|
||||
will exit with status 1. If there are syntax errors in a POD document
|
||||
being processed and the error handling style is set to the default of
|
||||
C<die>, B<pod2man> will abort immediately with exit status 255.
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Simple> for
|
||||
information about what those errors might mean.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
pod2man program > program.1
|
||||
pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
|
||||
pod2man --section=7 note.pod > note.7
|
||||
|
||||
If you would like to print out a lot of man page continuously, you probably
|
||||
want to set the C and D registers to set contiguous page numbering and
|
||||
even/odd paging, at least on some versions of man(7).
|
||||
|
||||
troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
|
||||
|
||||
To get index entries on C<STDERR>, turn on the F register, as in:
|
||||
|
||||
troff -man -rF1 perl.1
|
||||
|
||||
The indexing merely outputs messages via C<.tm> for each major page,
|
||||
section, subsection, item, and any C<XE<lt>E<gt>> directives. See
|
||||
L<Pod::Man> for more details.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Lots of this documentation is duplicated from L<Pod::Man>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Man>, L<Pod::Simple>, L<man(1)>, L<nroff(1)>, L<perlpod(1)>,
|
||||
L<podchecker(1)>, L<perlpodstyle(1)>, L<troff(1)>, L<man(7)>
|
||||
|
||||
The man page documenting the an macro set may be L<man(5)> instead of
|
||||
L<man(7)> on your system.
|
||||
|
||||
The current version of this script is always available from its web site at
|
||||
L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
|
||||
Perl core distribution as of 5.6.0.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
|
||||
B<pod2man> by Larry Wall and Tom Christiansen.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013 Russ
|
||||
Allbery <rra@stanford.edu>.
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,325 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
# pod2text -- Convert POD data to formatted ASCII text.
|
||||
#
|
||||
# Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013
|
||||
# Russ Allbery <rra@stanford.edu>
|
||||
#
|
||||
# This program is free software; you may redistribute it and/or modify it
|
||||
# under the same terms as Perl itself.
|
||||
#
|
||||
# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
|
||||
# invoked by perldoc -t among other things.
|
||||
|
||||
require 5.004;
|
||||
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Pod::Text ();
|
||||
use Pod::Usage qw(pod2usage);
|
||||
|
||||
use strict;
|
||||
|
||||
# Clean up $0 for error reporting.
|
||||
$0 =~ s%.*/%%;
|
||||
|
||||
# Take an initial pass through our options, looking for one of the form
|
||||
# -<number>. We turn that into -w <number> for compatibility with the
|
||||
# original pod2text script.
|
||||
for (my $i = 0; $i < @ARGV; $i++) {
|
||||
last if $ARGV[$i] =~ /^--$/;
|
||||
if ($ARGV[$i] =~ /^-(\d+)$/) {
|
||||
splice (@ARGV, $i++, 1, '-w', $1);
|
||||
}
|
||||
}
|
||||
|
||||
# Insert -- into @ARGV before any single dash argument to hide it from
|
||||
# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Simple
|
||||
# does correctly).
|
||||
my $stdin;
|
||||
@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
|
||||
|
||||
# Parse our options. Use the same names as Pod::Text for simplicity, and
|
||||
# default to sentence boundaries turned off for compatibility.
|
||||
my %options;
|
||||
$options{sentence} = 0;
|
||||
Getopt::Long::config ('bundling');
|
||||
GetOptions (\%options, 'alt|a', 'code', 'color|c', 'errors=s', 'help|h',
|
||||
'indent|i=i', 'loose|l', 'margin|left-margin|m=i', 'nourls',
|
||||
'overstrike|o', 'quotes|q=s', 'sentence|s', 'stderr', 'termcap|t',
|
||||
'utf8|u', 'width|w=i')
|
||||
or exit 1;
|
||||
pod2usage (1) if $options{help};
|
||||
|
||||
# Figure out what formatter we're going to use. -c overrides -t.
|
||||
my $formatter = 'Pod::Text';
|
||||
if ($options{color}) {
|
||||
$formatter = 'Pod::Text::Color';
|
||||
eval { require Term::ANSIColor };
|
||||
if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" }
|
||||
require Pod::Text::Color;
|
||||
} elsif ($options{termcap}) {
|
||||
$formatter = 'Pod::Text::Termcap';
|
||||
require Pod::Text::Termcap;
|
||||
} elsif ($options{overstrike}) {
|
||||
$formatter = 'Pod::Text::Overstrike';
|
||||
require Pod::Text::Overstrike;
|
||||
}
|
||||
delete @options{'color', 'termcap', 'overstrike'};
|
||||
|
||||
# If neither stderr nor errors is set, default to errors = die.
|
||||
if (!defined $options{stderr} && !defined $options{errors}) {
|
||||
$options{errors} = 'die';
|
||||
}
|
||||
|
||||
# Initialize and run the formatter.
|
||||
my $parser = $formatter->new (%options);
|
||||
my $status = 0;
|
||||
do {
|
||||
my ($input, $output) = splice (@ARGV, 0, 2);
|
||||
$parser->parse_from_file ($input, $output);
|
||||
if ($parser->{CONTENTLESS}) {
|
||||
$status = 1;
|
||||
warn "$0: unable to format $input\n";
|
||||
if (defined ($output) and $output ne '-') {
|
||||
unlink $output unless (-s $output);
|
||||
}
|
||||
}
|
||||
} while (@ARGV);
|
||||
exit $status;
|
||||
|
||||
__END__
|
||||
|
||||
=for stopwords
|
||||
-aclostu --alt --stderr Allbery --overstrike overstrike --termcap --utf8
|
||||
UTF-8 subclasses --nourls
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2text - Convert POD data to formatted ASCII text
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
pod2text [B<-aclostu>] [B<--code>] [B<--errors>=I<style>] [B<-i> I<indent>]
|
||||
S<[B<-q> I<quotes>]> [B<--nourls>] [B<--stderr>] S<[B<-w> I<width>]>
|
||||
[I<input> [I<output> ...]]
|
||||
|
||||
pod2text B<-h>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2text> is a front-end for Pod::Text and its subclasses. It uses them
|
||||
to generate formatted ASCII text from POD source. It can optionally use
|
||||
either termcap sequences or ANSI color escape sequences to format the text.
|
||||
|
||||
I<input> is the file to read for POD source (the POD can be embedded in
|
||||
code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
|
||||
given, is the file to which to write the formatted output. If I<output>
|
||||
isn't given, the formatted output is written to C<STDOUT>. Several POD
|
||||
files can be processed in the same B<pod2text> invocation (saving module
|
||||
load and compile times) by providing multiple pairs of I<input> and
|
||||
I<output> files on the command line.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<-a>, B<--alt>
|
||||
|
||||
Use an alternate output format that, among other things, uses a different
|
||||
heading style and marks C<=item> entries with a colon in the left margin.
|
||||
|
||||
=item B<--code>
|
||||
|
||||
Include any non-POD text from the input file in the output as well. Useful
|
||||
for viewing code documented with POD blocks with the POD rendered and the
|
||||
code left intact.
|
||||
|
||||
=item B<-c>, B<--color>
|
||||
|
||||
Format the output with ANSI color escape sequences. Using this option
|
||||
requires that Term::ANSIColor be installed on your system.
|
||||
|
||||
=item B<-i> I<indent>, B<--indent=>I<indent>
|
||||
|
||||
Set the number of spaces to indent regular text, and the default indentation
|
||||
for C<=over> blocks. Defaults to 4 spaces if this option isn't given.
|
||||
|
||||
=item B<-errors>=I<style>
|
||||
|
||||
Set the error handling style. C<die> says to throw an exception on any
|
||||
POD formatting error. C<stderr> says to report errors on standard error,
|
||||
but not to throw an exception. C<pod> says to include a POD ERRORS
|
||||
section in the resulting documentation summarizing the errors. C<none>
|
||||
ignores POD errors entirely, as much as possible.
|
||||
|
||||
The default is C<die>.
|
||||
|
||||
=item B<-h>, B<--help>
|
||||
|
||||
Print out usage information and exit.
|
||||
|
||||
=item B<-l>, B<--loose>
|
||||
|
||||
Print a blank line after a C<=head1> heading. Normally, no blank line is
|
||||
printed after C<=head1>, although one is still printed after C<=head2>,
|
||||
because this is the expected formatting for manual pages; if you're
|
||||
formatting arbitrary text documents, using this option is recommended.
|
||||
|
||||
=item B<-m> I<width>, B<--left-margin>=I<width>, B<--margin>=I<width>
|
||||
|
||||
The width of the left margin in spaces. Defaults to 0. This is the margin
|
||||
for all text, including headings, not the amount by which regular text is
|
||||
indented; for the latter, see B<-i> option.
|
||||
|
||||
=item B<--nourls>
|
||||
|
||||
Normally, LZ<><> formatting codes with a URL but anchor text are formatted
|
||||
to show both the anchor text and the URL. In other words:
|
||||
|
||||
L<foo|http://example.com/>
|
||||
|
||||
is formatted as:
|
||||
|
||||
foo <http://example.com/>
|
||||
|
||||
This flag, if given, suppresses the URL when anchor text is given, so this
|
||||
example would be formatted as just C<foo>. This can produce less
|
||||
cluttered output in cases where the URLs are not particularly important.
|
||||
|
||||
=item B<-o>, B<--overstrike>
|
||||
|
||||
Format the output with overstrike printing. Bold text is rendered as
|
||||
character, backspace, character. Italics and file names are rendered as
|
||||
underscore, backspace, character. Many pagers, such as B<less>, know how
|
||||
to convert this to bold or underlined text.
|
||||
|
||||
=item B<-q> I<quotes>, B<--quotes>=I<quotes>
|
||||
|
||||
Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
|
||||
I<quotes> is a single character, it is used as both the left and right
|
||||
quote; if I<quotes> is two characters, the first character is used as the
|
||||
left quote and the second as the right quoted; and if I<quotes> is four
|
||||
characters, the first two are used as the left quote and the second two as
|
||||
the right quote.
|
||||
|
||||
I<quotes> may also be set to the special value C<none>, in which case no
|
||||
quote marks are added around CE<lt>> text.
|
||||
|
||||
=item B<-s>, B<--sentence>
|
||||
|
||||
Assume each sentence ends with two spaces and try to preserve that spacing.
|
||||
Without this option, all consecutive whitespace in non-verbatim paragraphs
|
||||
is compressed into a single space.
|
||||
|
||||
=item B<--stderr>
|
||||
|
||||
By default, B<pod2text> dies if any errors are detected in the POD input.
|
||||
If B<--stderr> is given and no B<--errors> flag is present, errors are
|
||||
sent to standard error, but B<pod2text> does not abort. This is
|
||||
equivalent to C<--errors=stderr> and is supported for backward
|
||||
compatibility.
|
||||
|
||||
=item B<-t>, B<--termcap>
|
||||
|
||||
Try to determine the width of the screen and the bold and underline
|
||||
sequences for the terminal from termcap, and use that information in
|
||||
formatting the output. Output will be wrapped at two columns less than the
|
||||
width of your terminal device. Using this option requires that your system
|
||||
have a termcap file somewhere where Term::Cap can find it and requires that
|
||||
your system support termios. With this option, the output of B<pod2text>
|
||||
will contain terminal control sequences for your current terminal type.
|
||||
|
||||
=item B<-u>, B<--utf8>
|
||||
|
||||
By default, B<pod2text> tries to use the same output encoding as its input
|
||||
encoding (to be backward-compatible with older versions). This option
|
||||
says to instead force the output encoding to UTF-8.
|
||||
|
||||
Be aware that, when using this option, the input encoding of your POD
|
||||
source must be properly declared unless it is US-ASCII or Latin-1. POD
|
||||
input without an C<=encoding> command will be assumed to be in Latin-1,
|
||||
and if it's actually in UTF-8, the output will be double-encoded. See
|
||||
L<perlpod(1)> for more information on the C<=encoding> command.
|
||||
|
||||
=item B<-w>, B<--width=>I<width>, B<->I<width>
|
||||
|
||||
The column at which to wrap text on the right-hand side. Defaults to 76,
|
||||
unless B<-t> is given, in which case it's two columns less than the width of
|
||||
your terminal device.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXIT STATUS
|
||||
|
||||
As long as all documents processed result in some output, even if that
|
||||
output includes errata (a C<POD ERRORS> section generated with
|
||||
C<--errors=pod>), B<pod2text> will exit with status 0. If any of the
|
||||
documents being processed do not result in an output document, B<pod2text>
|
||||
will exit with status 1. If there are syntax errors in a POD document
|
||||
being processed and the error handling style is set to the default of
|
||||
C<die>, B<pod2text> will abort immediately with exit status 255.
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Simple> for
|
||||
information about what those errors might mean. Internally, it can also
|
||||
produce the following diagnostics:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -c (--color) requires Term::ANSIColor be installed
|
||||
|
||||
(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be
|
||||
loaded.
|
||||
|
||||
=item Unknown option: %s
|
||||
|
||||
(F) An unknown command line option was given.
|
||||
|
||||
=back
|
||||
|
||||
In addition, other L<Getopt::Long> error messages may result from invalid
|
||||
command-line options.
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
=over 4
|
||||
|
||||
=item COLUMNS
|
||||
|
||||
If B<-t> is given, B<pod2text> will take the current width of your screen
|
||||
from this environment variable, if available. It overrides terminal width
|
||||
information in TERMCAP.
|
||||
|
||||
=item TERMCAP
|
||||
|
||||
If B<-t> is given, B<pod2text> will use the contents of this environment
|
||||
variable if available to determine the correct formatting sequences for your
|
||||
current terminal device.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Text::Overstrike>,
|
||||
L<Pod::Text::Termcap>, L<Pod::Simple>, L<perlpod(1)>
|
||||
|
||||
The current version of this script is always available from its web site at
|
||||
L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
|
||||
Perl core distribution as of 5.6.0.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Russ Allbery <rra@stanford.edu>.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 1999, 2000, 2001, 2004, 2006, 2008, 2010, 2012, 2013 Russ
|
||||
Allbery <rra@stanford.edu>.
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,151 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec perl -S $0 "$@"'
|
||||
if 0;
|
||||
|
||||
#############################################################################
|
||||
# pod2usage -- command to print usage messages from embedded pod docs
|
||||
#
|
||||
# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
|
||||
# This file is part of "PodParser". PodParser is free software;
|
||||
# you can redistribute it and/or modify it under the same terms
|
||||
# as Perl itself.
|
||||
#############################################################################
|
||||
|
||||
use strict;
|
||||
#use diagnostics;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
pod2usage - print usage messages from embedded pod docs in files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=over 12
|
||||
|
||||
=item B<pod2usage>
|
||||
|
||||
[B<-help>]
|
||||
[B<-man>]
|
||||
[B<-exit>S< >I<exitval>]
|
||||
[B<-output>S< >I<outfile>]
|
||||
[B<-verbose> I<level>]
|
||||
[B<-pathlist> I<dirlist>]
|
||||
[B<-formatter> I<module>]
|
||||
I<file>
|
||||
|
||||
=back
|
||||
|
||||
=head1 OPTIONS AND ARGUMENTS
|
||||
|
||||
=over 8
|
||||
|
||||
=item B<-help>
|
||||
|
||||
Print a brief help message and exit.
|
||||
|
||||
=item B<-man>
|
||||
|
||||
Print this command's manual page and exit.
|
||||
|
||||
=item B<-exit> I<exitval>
|
||||
|
||||
The exit status value to return.
|
||||
|
||||
=item B<-output> I<outfile>
|
||||
|
||||
The output file to print to. If the special names "-" or ">&1" or ">&STDOUT"
|
||||
are used then standard output is used. If ">&2" or ">&STDERR" is used then
|
||||
standard error is used.
|
||||
|
||||
=item B<-verbose> I<level>
|
||||
|
||||
The desired level of verbosity to use:
|
||||
|
||||
1 : print SYNOPSIS only
|
||||
2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections
|
||||
3 : print the entire manpage (similar to running pod2text)
|
||||
|
||||
=item B<-pathlist> I<dirlist>
|
||||
|
||||
Specifies one or more directories to search for the input file if it
|
||||
was not supplied with an absolute path. Each directory path in the given
|
||||
list should be separated by a ':' on Unix (';' on MSWin32 and DOS).
|
||||
|
||||
=item B<-formatter> I<module>
|
||||
|
||||
Which text formatter to use. Default is L<Pod::Text>, or for very old
|
||||
Perl versions L<Pod::PlainText>. An alternative would be e.g.
|
||||
L<Pod::Text::Termcap>.
|
||||
|
||||
=item I<file>
|
||||
|
||||
The pathname of a file containing pod documentation to be output in
|
||||
usage message format (defaults to standard input).
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<pod2usage> will read the given input file looking for pod
|
||||
documentation and will print the corresponding usage message.
|
||||
If no input file is specified then standard input is read.
|
||||
|
||||
B<pod2usage> invokes the B<pod2usage()> function in the B<Pod::Usage>
|
||||
module. Please see L<Pod::Usage/pod2usage()>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Usage>, L<pod2text(1)>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Please report bugs using L<http://rt.cpan.org>.
|
||||
|
||||
Brad Appleton E<lt>bradapp@enteract.comE<gt>
|
||||
|
||||
Based on code for B<pod2text(1)> written by
|
||||
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
## Define options
|
||||
my %options = ();
|
||||
my @opt_specs = (
|
||||
'help',
|
||||
'man',
|
||||
'exit=i',
|
||||
'output=s',
|
||||
'pathlist=s',
|
||||
'formatter=s',
|
||||
'verbose=i',
|
||||
);
|
||||
|
||||
## Parse options
|
||||
GetOptions(\%options, @opt_specs) || pod2usage(2);
|
||||
$Pod::Usage::Formatter = $options{formatter} if $options{formatter};
|
||||
require Pod::Usage;
|
||||
Pod::Usage->import();
|
||||
pod2usage(1) if ($options{help});
|
||||
pod2usage(VERBOSE => 2) if ($options{man});
|
||||
|
||||
## Dont default to STDIN if connected to a terminal
|
||||
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
|
||||
|
||||
@ARGV = ('-') unless (@ARGV);
|
||||
if (@ARGV > 1) {
|
||||
print STDERR "pod2usage: Too many filenames given\n\n";
|
||||
pod2usage(2);
|
||||
}
|
||||
|
||||
my %usage = ();
|
||||
$usage{-input} = shift(@ARGV);
|
||||
$usage{-exitval} = $options{'exit'} if (defined $options{'exit'});
|
||||
$usage{-output} = $options{'output'} if (defined $options{'output'});
|
||||
$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'});
|
||||
$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'});
|
||||
|
||||
pod2usage(\%usage);
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec perl -S $0 "$@"'
|
||||
if 0;
|
||||
#############################################################################
|
||||
# podchecker -- command to invoke the podchecker function in Pod::Checker
|
||||
#
|
||||
# Copyright (c) 1998-2000 by Bradford Appleton. All rights reserved.
|
||||
# This file is part of "PodParser". PodParser is free software;
|
||||
# you can redistribute it and/or modify it under the same terms
|
||||
# as Perl itself.
|
||||
#############################################################################
|
||||
|
||||
use strict;
|
||||
#use diagnostics;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
podchecker - check the syntax of POD format documentation files
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<podchecker> [B<-help>] [B<-man>] [B<-(no)warnings>] [I<file>S< >...]
|
||||
|
||||
=head1 OPTIONS AND ARGUMENTS
|
||||
|
||||
=over 8
|
||||
|
||||
=item B<-help>
|
||||
|
||||
Print a brief help message and exit.
|
||||
|
||||
=item B<-man>
|
||||
|
||||
Print the manual page and exit.
|
||||
|
||||
=item B<-warnings> B<-nowarnings>
|
||||
|
||||
Turn on/off printing of warnings. Repeating B<-warnings> increases the
|
||||
warning level, i.e. more warnings are printed. Currently increasing to
|
||||
level two causes flagging of unescaped "E<lt>,E<gt>" characters.
|
||||
|
||||
=item I<file>
|
||||
|
||||
The pathname of a POD file to syntax-check (defaults to standard input).
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<podchecker> will read the given input files looking for POD
|
||||
syntax errors in the POD documentation and will print any errors
|
||||
it find to STDERR. At the end, it will print a status message
|
||||
indicating the number of errors found.
|
||||
|
||||
Directories are ignored, an appropriate warning message is printed.
|
||||
|
||||
B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker>
|
||||
Please see L<Pod::Checker/podchecker()> for more details.
|
||||
|
||||
=head1 RETURN VALUE
|
||||
|
||||
B<podchecker> returns a 0 (zero) exit status if all specified
|
||||
POD files are ok.
|
||||
|
||||
=head1 ERRORS
|
||||
|
||||
B<podchecker> returns the exit status 1 if at least one of
|
||||
the given POD files has syntax errors.
|
||||
|
||||
The status 2 indicates that at least one of the specified
|
||||
files does not contain I<any> POD commands.
|
||||
|
||||
Status 1 overrides status 2. If you want unambiguous
|
||||
results, call B<podchecker> with one single argument only.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Parser> and L<Pod::Checker>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Please report bugs using L<http://rt.cpan.org>.
|
||||
|
||||
Brad Appleton E<lt>bradapp@enteract.comE<gt>,
|
||||
Marek Rouchal E<lt>marekr@cpan.orgE<gt>
|
||||
|
||||
Based on code for B<Pod::Text::pod2text(1)> written by
|
||||
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
use Pod::Checker;
|
||||
use Pod::Usage;
|
||||
use Getopt::Long;
|
||||
|
||||
## Define options
|
||||
my %options;
|
||||
|
||||
## Parse options
|
||||
GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2);
|
||||
pod2usage(1) if ($options{help});
|
||||
pod2usage(-verbose => 2) if ($options{man});
|
||||
|
||||
if($options{nowarnings}) {
|
||||
$options{warnings} = 0;
|
||||
}
|
||||
elsif(!defined $options{warnings}) {
|
||||
$options{warnings} = 1; # default is warnings on
|
||||
}
|
||||
|
||||
## Dont default to STDIN if connected to a terminal
|
||||
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
|
||||
|
||||
## Invoke podchecker()
|
||||
my $status = 0;
|
||||
@ARGV = qw(-) unless(@ARGV);
|
||||
for my $podfile (@ARGV) {
|
||||
if($podfile eq '-') {
|
||||
$podfile = '<&STDIN';
|
||||
}
|
||||
elsif(-d $podfile) {
|
||||
warn "podchecker: Warning: Ignoring directory '$podfile'\n";
|
||||
next;
|
||||
}
|
||||
my $errors =
|
||||
podchecker($podfile, undef, '-warnings' => $options{warnings});
|
||||
if($errors > 0) {
|
||||
# errors occurred
|
||||
$status = 1;
|
||||
printf STDERR ("%s has %d pod syntax %s.\n",
|
||||
$podfile, $errors,
|
||||
($errors == 1) ? 'error' : 'errors');
|
||||
}
|
||||
elsif($errors < 0) {
|
||||
# no pod found
|
||||
$status = 2 unless($status);
|
||||
print STDERR "$podfile does not contain any pod commands.\n";
|
||||
}
|
||||
else {
|
||||
print STDERR "$podfile pod syntax OK.\n";
|
||||
}
|
||||
}
|
||||
exit $status;
|
||||
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec perl -S $0 "$@"'
|
||||
if 0;
|
||||
|
||||
#############################################################################
|
||||
# podselect -- command to invoke the podselect function in Pod::Select
|
||||
#
|
||||
# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
|
||||
# This file is part of "PodParser". PodParser is free software;
|
||||
# you can redistribute it and/or modify it under the same terms
|
||||
# as Perl itself.
|
||||
#############################################################################
|
||||
|
||||
use strict;
|
||||
#use diagnostics;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
podselect - print selected sections of pod documentation on standard output
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<podselect> [B<-help>] [B<-man>] [B<-section>S< >I<section-spec>]
|
||||
[I<file>S< >...]
|
||||
|
||||
=head1 OPTIONS AND ARGUMENTS
|
||||
|
||||
=over 8
|
||||
|
||||
=item B<-help>
|
||||
|
||||
Print a brief help message and exit.
|
||||
|
||||
=item B<-man>
|
||||
|
||||
Print the manual page and exit.
|
||||
|
||||
=item B<-section>S< >I<section-spec>
|
||||
|
||||
Specify a section to include in the output.
|
||||
See L<Pod::Parser/"SECTION SPECIFICATIONS">
|
||||
for the format to use for I<section-spec>.
|
||||
This option may be given multiple times on the command line.
|
||||
|
||||
=item I<file>
|
||||
|
||||
The pathname of a file from which to select sections of pod
|
||||
documentation (defaults to standard input).
|
||||
|
||||
=back
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<podselect> will read the given input files looking for pod
|
||||
documentation and will print out (in raw pod format) all sections that
|
||||
match one ore more of the given section specifications. If no section
|
||||
specifications are given than all pod sections encountered are output.
|
||||
|
||||
B<podselect> invokes the B<podselect()> function exported by B<Pod::Select>
|
||||
Please see L<Pod::Select/podselect()> for more details.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Pod::Parser> and L<Pod::Select>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Please report bugs using L<http://rt.cpan.org>.
|
||||
|
||||
Brad Appleton E<lt>bradapp@enteract.comE<gt>
|
||||
|
||||
Based on code for B<Pod::Text::pod2text(1)> written by
|
||||
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
use Pod::Select;
|
||||
use Pod::Usage;
|
||||
use Getopt::Long;
|
||||
|
||||
## Define options
|
||||
my %options = (
|
||||
'help' => 0,
|
||||
'man' => 0,
|
||||
'sections' => [],
|
||||
);
|
||||
|
||||
## Parse options
|
||||
GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2);
|
||||
pod2usage(1) if ($options{help});
|
||||
pod2usage(-verbose => 2) if ($options{man});
|
||||
|
||||
## Dont default to STDIN if connected to a terminal
|
||||
pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
|
||||
|
||||
## Invoke podselect().
|
||||
if (@{ $options{'sections'} } > 0) {
|
||||
podselect({ -sections => $options{'sections'} }, @ARGV);
|
||||
}
|
||||
else {
|
||||
podselect(@ARGV);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,408 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use App::Prove;
|
||||
|
||||
my $app = App::Prove->new;
|
||||
$app->process_args(@ARGV);
|
||||
exit( $app->run ? 0 : 1 );
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
prove - Run tests through a TAP harness.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
prove [options] [files or directories]
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Boolean options:
|
||||
|
||||
-v, --verbose Print all test lines.
|
||||
-l, --lib Add 'lib' to the path for your tests (-Ilib).
|
||||
-b, --blib Add 'blib/lib' and 'blib/arch' to the path for
|
||||
your tests
|
||||
-s, --shuffle Run the tests in random order.
|
||||
-c, --color Colored test output (default).
|
||||
--nocolor Do not color test output.
|
||||
--count Show the X/Y test count when not verbose
|
||||
(default)
|
||||
--nocount Disable the X/Y test count.
|
||||
-D --dry Dry run. Show test that would have run.
|
||||
-f, --failures Show failed tests.
|
||||
-o, --comments Show comments.
|
||||
--ignore-exit Ignore exit status from test scripts.
|
||||
-m, --merge Merge test scripts' STDERR with their STDOUT.
|
||||
-r, --recurse Recursively descend into directories.
|
||||
--reverse Run the tests in reverse order.
|
||||
-q, --quiet Suppress some test output while running tests.
|
||||
-Q, --QUIET Only print summary results.
|
||||
-p, --parse Show full list of TAP parse errors, if any.
|
||||
--directives Only show results with TODO or SKIP directives.
|
||||
--timer Print elapsed time after each test.
|
||||
--trap Trap Ctrl-C and print summary on interrupt.
|
||||
--normalize Normalize TAP output in verbose output
|
||||
-T Enable tainting checks.
|
||||
-t Enable tainting warnings.
|
||||
-W Enable fatal warnings.
|
||||
-w Enable warnings.
|
||||
-h, --help Display this help
|
||||
-?, Display this help
|
||||
-V, --version Display the version
|
||||
-H, --man Longer manpage for prove
|
||||
--norc Don't process default .proverc
|
||||
|
||||
Options that take arguments:
|
||||
|
||||
-I Library paths to include.
|
||||
-P Load plugin (searches App::Prove::Plugin::*.)
|
||||
-M Load a module.
|
||||
-e, --exec Interpreter to run the tests ('' for compiled
|
||||
tests.)
|
||||
--ext Set the extension for tests (default '.t')
|
||||
--harness Define test harness to use. See TAP::Harness.
|
||||
--formatter Result formatter to use. See FORMATTERS.
|
||||
--source Load and/or configure a SourceHandler. See
|
||||
SOURCE HANDLERS.
|
||||
-a, --archive out.tgz Store the resulting TAP in an archive file.
|
||||
-j, --jobs N Run N test jobs in parallel (try 9.)
|
||||
--state=opts Control prove's persistent state.
|
||||
--rc=rcfile Process options from rcfile
|
||||
--rules Rules for parallel vs sequential processing.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=head2 .proverc
|
||||
|
||||
If F<~/.proverc> or F<./.proverc> exist they will be read and any
|
||||
options they contain processed before the command line options. Options
|
||||
in F<.proverc> are specified in the same way as command line options:
|
||||
|
||||
# .proverc
|
||||
--state=hot,fast,save
|
||||
-j9
|
||||
|
||||
Additional option files may be specified with the C<--rc> option.
|
||||
Default option file processing is disabled by the C<--norc> option.
|
||||
|
||||
Under Windows and VMS the option file is named F<_proverc> rather than
|
||||
F<.proverc> and is sought only in the current directory.
|
||||
|
||||
=head2 Reading from C<STDIN>
|
||||
|
||||
If you have a list of tests (or URLs, or anything else you want to test) in a
|
||||
file, you can add them to your tests by using a '-':
|
||||
|
||||
prove - < my_list_of_things_to_test.txt
|
||||
|
||||
See the C<README> in the C<examples> directory of this distribution.
|
||||
|
||||
=head2 Default Test Directory
|
||||
|
||||
If no files or directories are supplied, C<prove> looks for all files
|
||||
matching the pattern C<t/*.t>.
|
||||
|
||||
=head2 Colored Test Output
|
||||
|
||||
Colored test output using L<TAP::Formatter::Color> is the default, but
|
||||
if output is not to a terminal, color is disabled. You can override this by
|
||||
adding the C<--color> switch.
|
||||
|
||||
Color support requires L<Term::ANSIColor> on Unix-like platforms and
|
||||
L<Win32::Console> on windows. If the necessary module is not installed
|
||||
colored output will not be available.
|
||||
|
||||
=head2 Exit Code
|
||||
|
||||
If the tests fail C<prove> will exit with non-zero status.
|
||||
|
||||
=head2 Arguments to Tests
|
||||
|
||||
It is possible to supply arguments to tests. To do so separate them from
|
||||
prove's own arguments with the arisdottle, '::'. For example
|
||||
|
||||
prove -v t/mytest.t :: --url http://example.com
|
||||
|
||||
would run F<t/mytest.t> with the options '--url http://example.com'.
|
||||
When running multiple tests they will each receive the same arguments.
|
||||
|
||||
=head2 C<--exec>
|
||||
|
||||
Normally you can just pass a list of Perl tests and the harness will know how
|
||||
to execute them. However, if your tests are not written in Perl or if you
|
||||
want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
|
||||
switch:
|
||||
|
||||
prove --exec '/usr/bin/ruby -w' t/
|
||||
prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
|
||||
prove --exec '/path/to/my/customer/exec'
|
||||
|
||||
=head2 C<--merge>
|
||||
|
||||
If you need to make sure your diagnostics are displayed in the correct
|
||||
order relative to test results you can use the C<--merge> option to
|
||||
merge the test scripts' STDERR into their STDOUT.
|
||||
|
||||
This guarantees that STDOUT (where the test results appear) and STDERR
|
||||
(where the diagnostics appear) will stay in sync. The harness will
|
||||
display any diagnostics your tests emit on STDERR.
|
||||
|
||||
Caveat: this is a bit of a kludge. In particular note that if anything
|
||||
that appears on STDERR looks like a test result the test harness will
|
||||
get confused. Use this option only if you understand the consequences
|
||||
and can live with the risk.
|
||||
|
||||
=head2 C<--trap>
|
||||
|
||||
The C<--trap> option will attempt to trap SIGINT (Ctrl-C) during a test
|
||||
run and display the test summary even if the run is interrupted
|
||||
|
||||
=head2 C<--state>
|
||||
|
||||
You can ask C<prove> to remember the state of previous test runs and
|
||||
select and/or order the tests to be run based on that saved state.
|
||||
|
||||
The C<--state> switch requires an argument which must be a comma
|
||||
separated list of one or more of the following options.
|
||||
|
||||
=over
|
||||
|
||||
=item C<last>
|
||||
|
||||
Run the same tests as the last time the state was saved. This makes it
|
||||
possible, for example, to recreate the ordering of a shuffled test.
|
||||
|
||||
# Run all tests in random order
|
||||
$ prove -b --state=save --shuffle
|
||||
|
||||
# Run them again in the same order
|
||||
$ prove -b --state=last
|
||||
|
||||
=item C<failed>
|
||||
|
||||
Run only the tests that failed on the last run.
|
||||
|
||||
# Run all tests
|
||||
$ prove -b --state=save
|
||||
|
||||
# Run failures
|
||||
$ prove -b --state=failed
|
||||
|
||||
If you also specify the C<save> option newly passing tests will be
|
||||
excluded from subsequent runs.
|
||||
|
||||
# Repeat until no more failures
|
||||
$ prove -b --state=failed,save
|
||||
|
||||
=item C<passed>
|
||||
|
||||
Run only the passed tests from last time. Useful to make sure that no
|
||||
new problems have been introduced.
|
||||
|
||||
=item C<all>
|
||||
|
||||
Run all tests in normal order. Multple options may be specified, so to
|
||||
run all tests with the failures from last time first:
|
||||
|
||||
$ prove -b --state=failed,all,save
|
||||
|
||||
=item C<hot>
|
||||
|
||||
Run the tests that most recently failed first. The last failure time of
|
||||
each test is stored. The C<hot> option causes tests to be run in most-recent-
|
||||
failure order.
|
||||
|
||||
$ prove -b --state=hot,save
|
||||
|
||||
Tests that have never failed will not be selected. To run all tests with
|
||||
the most recently failed first use
|
||||
|
||||
$ prove -b --state=hot,all,save
|
||||
|
||||
This combination of options may also be specified thus
|
||||
|
||||
$ prove -b --state=adrian
|
||||
|
||||
=item C<todo>
|
||||
|
||||
Run any tests with todos.
|
||||
|
||||
=item C<slow>
|
||||
|
||||
Run the tests in slowest to fastest order. This is useful in conjunction
|
||||
with the C<-j> parallel testing switch to ensure that your slowest tests
|
||||
start running first.
|
||||
|
||||
$ prove -b --state=slow -j9
|
||||
|
||||
=item C<fast>
|
||||
|
||||
Run test tests in fastest to slowest order.
|
||||
|
||||
=item C<new>
|
||||
|
||||
Run the tests in newest to oldest order based on the modification times
|
||||
of the test scripts.
|
||||
|
||||
=item C<old>
|
||||
|
||||
Run the tests in oldest to newest order.
|
||||
|
||||
=item C<fresh>
|
||||
|
||||
Run those test scripts that have been modified since the last test run.
|
||||
|
||||
=item C<save>
|
||||
|
||||
Save the state on exit. The state is stored in a file called F<.prove>
|
||||
(F<_prove> on Windows and VMS) in the current directory.
|
||||
|
||||
=back
|
||||
|
||||
The C<--state> switch may be used more than once.
|
||||
|
||||
$ prove -b --state=hot --state=all,save
|
||||
|
||||
=head2 --rules
|
||||
|
||||
The C<--rules> option is used to control which tests are run sequentially and
|
||||
which are run in parallel, if the C<--jobs> option is specified. The option may
|
||||
be specified multiple times, and the order matters.
|
||||
|
||||
The most practical use is likely to specify that some tests are not
|
||||
"parallel-ready". Since mentioning a file with --rules doesn't cause it to
|
||||
be selected to run as a test, you can "set and forget" some rules preferences in
|
||||
your .proverc file. Then you'll be able to take maximum advantage of the
|
||||
performance benefits of parallel testing, while some exceptions are still run
|
||||
in parallel.
|
||||
|
||||
=head3 --rules examples
|
||||
|
||||
# All tests are allowed to run in parallel, except those starting with "p"
|
||||
--rules='seq=t/p*.t' --rules='par=**'
|
||||
|
||||
# All tests must run in sequence except those starting with "p", which should be run parallel
|
||||
--rules='par=t/p*.t'
|
||||
|
||||
=head3 --rules resolution
|
||||
|
||||
=over 4
|
||||
|
||||
=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
|
||||
|
||||
=item * "First match wins". The first rule that matches a test will be the one that applies.
|
||||
|
||||
=item * Any test which does not match a rule will be run in sequence at the end of the run.
|
||||
|
||||
=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
|
||||
|
||||
=item * Specifying a rule to allow tests to run in parallel does not make them run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
|
||||
|
||||
=back
|
||||
|
||||
=head3 --rules Glob-style pattern matching
|
||||
|
||||
We implement our own glob-style pattern matching for --rules. Here are the
|
||||
supported patterns:
|
||||
|
||||
** is any number of characters, including /, within a pathname
|
||||
* is zero or more characters within a filename/directory name
|
||||
? is exactly one character within a filename/directory name
|
||||
{foo,bar,baz} is any of foo, bar or baz.
|
||||
\ is an escape character
|
||||
|
||||
=head3 More advanced specifications for parallel vs sequence run rules
|
||||
|
||||
If you need more advanced management of what runs in parallel vs in sequence, see
|
||||
the associated 'rules' documentation in L<TAP::Harness> and L<TAP::Parser::Scheduler>.
|
||||
If what's possible directly through C<prove> is not sufficient, you can write your own
|
||||
harness to access these features directly.
|
||||
|
||||
=head2 @INC
|
||||
|
||||
prove introduces a separation between "options passed to the perl which
|
||||
runs prove" and "options passed to the perl which runs tests"; this
|
||||
distinction is by design. Thus the perl which is running a test starts
|
||||
with the default C<@INC>. Additional library directories can be added
|
||||
via the C<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or
|
||||
via the C<-Ilib> option to F<prove>.
|
||||
|
||||
=head2 Taint Mode
|
||||
|
||||
Normally when a Perl program is run in taint mode the contents of the
|
||||
C<PERL5LIB> environment variable do not appear in C<@INC>.
|
||||
|
||||
Because C<PERL5LIB> is often used during testing to add build
|
||||
directories to C<@INC> prove passes the names of any directories found
|
||||
in C<PERL5LIB> as -I switches. The net effect of this is that
|
||||
C<PERL5LIB> is honoured even when prove is run in taint mode.
|
||||
|
||||
|
||||
=head1 FORMATTERS
|
||||
|
||||
You can load a custom L<TAP::Parser::Formatter>:
|
||||
|
||||
prove --formatter MyFormatter
|
||||
|
||||
=head1 SOURCE HANDLERS
|
||||
|
||||
You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
|
||||
parser interprets particular I<sources> of TAP.
|
||||
|
||||
prove --source MyHandler --source YetAnother t
|
||||
|
||||
If you want to provide config to the source you can use:
|
||||
|
||||
prove --source MyCustom \
|
||||
--source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
|
||||
--source File --file-option extensions=.txt --file-option extensions=.tmp t
|
||||
--source pgTAP --pgtap-option pset=format=html --pgtap-option pset=border=2
|
||||
|
||||
Each C<--$source-option> option must specify a key/value pair separated by an
|
||||
C<=>. If an option can take multiple values, just specify it multiple times,
|
||||
as with the C<extensions=> examples above. If the option should be a hash
|
||||
reference, specify the value as a second pair separated by a C<=>, as in the
|
||||
C<pset=> examples above (escape C<=> with a backslash).
|
||||
|
||||
All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
|
||||
C<sources> parameter.
|
||||
|
||||
See L<TAP::Parser::IteratorFactory> for more details on how configuration is
|
||||
passed to I<SourceHandlers>.
|
||||
|
||||
=head1 PLUGINS
|
||||
|
||||
Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
|
||||
|
||||
prove -PMyPlugin
|
||||
|
||||
This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
|
||||
that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
|
||||
|
||||
You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
|
||||
plugin name:
|
||||
|
||||
prove -PMyPlugin=fou,du,fafa
|
||||
|
||||
Please check individual plugin documentation for more details.
|
||||
|
||||
=head2 Available Plugins
|
||||
|
||||
For an up-to-date list of plugins available, please check CPAN:
|
||||
|
||||
L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
|
||||
|
||||
=head2 Writing Plugins
|
||||
|
||||
Please see L<App::Prove/PLUGINS>.
|
||||
|
||||
=cut
|
||||
|
||||
# vim:ts=4:sw=4:et:sta
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,141 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
use strict;
|
||||
|
||||
use File::Find;
|
||||
use Getopt::Std;
|
||||
use Archive::Tar;
|
||||
use Data::Dumper;
|
||||
|
||||
# Allow historic support for dashless bundled options
|
||||
# tar cvf file.tar
|
||||
# is valid (GNU) tar style
|
||||
@ARGV && $ARGV[0] =~ m/^[DdcvzthxIC]+[fT]?$/ and
|
||||
unshift @ARGV, map { "-$_" } split m// => shift @ARGV;
|
||||
my $opts = {};
|
||||
getopts('Ddcvzthxf:ICT:', $opts) or die usage();
|
||||
|
||||
### show the help message ###
|
||||
die usage() if $opts->{h};
|
||||
|
||||
### enable debugging (undocumented feature)
|
||||
local $Archive::Tar::DEBUG = 1 if $opts->{d};
|
||||
|
||||
### enable insecure extracting.
|
||||
local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I};
|
||||
|
||||
### sanity checks ###
|
||||
unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
|
||||
die "You need exactly one of 'x', 't' or 'c' options: " . usage();
|
||||
}
|
||||
|
||||
my $compress = $opts->{z} ? 1 : 0;
|
||||
my $verbose = $opts->{v} ? 1 : 0;
|
||||
my $file = $opts->{f} ? $opts->{f} : 'default.tar';
|
||||
my $tar = Archive::Tar->new();
|
||||
|
||||
if( $opts->{c} ) {
|
||||
my @files;
|
||||
my @src = @ARGV;
|
||||
if( $opts->{T} ) {
|
||||
if( $opts->{T} eq "-" ) {
|
||||
chomp( @src = <STDIN> );
|
||||
} elsif( open my $fh, "<", $opts->{T} ) {
|
||||
chomp( @src = <$fh> );
|
||||
} else {
|
||||
die "$0: $opts->{T}: $!\n";
|
||||
}
|
||||
}
|
||||
|
||||
find( sub { push @files, $File::Find::name;
|
||||
print $File::Find::name.$/ if $verbose }, @src );
|
||||
|
||||
if ($file eq '-') {
|
||||
use IO::Handle;
|
||||
$file = IO::Handle->new();
|
||||
$file->fdopen(fileno(STDOUT),"w");
|
||||
}
|
||||
|
||||
my $tar = Archive::Tar->new;
|
||||
$tar->add_files(@files);
|
||||
if( $opts->{C} ) {
|
||||
for my $f ($tar->get_files) {
|
||||
$f->mode($f->mode & ~022); # chmod go-w
|
||||
}
|
||||
}
|
||||
$tar->write($file, $compress);
|
||||
} else {
|
||||
if ($file eq '-') {
|
||||
use IO::Handle;
|
||||
$file = IO::Handle->new();
|
||||
$file->fdopen(fileno(STDIN),"r");
|
||||
}
|
||||
|
||||
### print the files we're finding?
|
||||
my $print = $verbose || $opts->{'t'} || 0;
|
||||
|
||||
my $iter = Archive::Tar->iter( $file );
|
||||
|
||||
while( my $f = $iter->() ) {
|
||||
print $f->full_path . $/ if $print;
|
||||
|
||||
### data dumper output
|
||||
print Dumper( $f ) if $opts->{'D'};
|
||||
|
||||
### extract it
|
||||
$f->extract if $opts->{'x'};
|
||||
}
|
||||
}
|
||||
|
||||
### pod & usage in one
|
||||
sub usage {
|
||||
my $usage .= << '=cut';
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptar - a tar-like program written in perl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ptar is a small, tar look-alike program that uses the perl module
|
||||
Archive::Tar to extract, create and list tar archives.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptar -c [-v] [-z] [-C] [-f ARCHIVE_FILE | -] FILE FILE ...
|
||||
ptar -c [-v] [-z] [-C] [-T index | -] [-f ARCHIVE_FILE | -]
|
||||
ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
|
||||
ptar -t [-z] [-f ARCHIVE_FILE | -]
|
||||
ptar -h
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
c Create ARCHIVE_FILE or STDOUT (-) from FILE
|
||||
x Extract from ARCHIVE_FILE or STDIN (-)
|
||||
t List the contents of ARCHIVE_FILE or STDIN (-)
|
||||
f Name of the ARCHIVE_FILE to use. Default is './default.tar'
|
||||
z Read/Write zlib compressed ARCHIVE_FILE (not always available)
|
||||
v Print filenames as they are added or extracted from ARCHIVE_FILE
|
||||
h Prints this help message
|
||||
C CPAN mode - drop 022 from permissions
|
||||
T get names to create from file
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
tar(1), L<Archive::Tar>.
|
||||
|
||||
=cut
|
||||
|
||||
### strip the pod directives
|
||||
$usage =~ s/=pod\n//g;
|
||||
$usage =~ s/=head1 //g;
|
||||
|
||||
### add some newlines
|
||||
$usage .= $/.$/;
|
||||
|
||||
return $usage;
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,119 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use Archive::Tar;
|
||||
use Getopt::Std;
|
||||
|
||||
my $opts = {};
|
||||
getopts('h:', $opts) or die usage();
|
||||
|
||||
die usages() if $opts->{h};
|
||||
|
||||
### need Text::Diff -- give a polite error (not a standard prereq)
|
||||
unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) {
|
||||
die "\n\t This tool requires the 'Text::Diff' module to be installed\n";
|
||||
}
|
||||
|
||||
my $arch = shift or die usage();
|
||||
my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!";
|
||||
|
||||
|
||||
foreach my $file ( $tar->get_files ) {
|
||||
next unless $file->is_file;
|
||||
my $prefix = $file->prefix;
|
||||
my $name = $file->name;
|
||||
if (defined $prefix) {
|
||||
$name = File::Spec->catfile($prefix, $name);
|
||||
}
|
||||
|
||||
diff( \($file->get_content), $name,
|
||||
{ FILENAME_A => $name,
|
||||
MTIME_A => $file->mtime,
|
||||
OUTPUT => \*STDOUT
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
sub usage {
|
||||
return q[
|
||||
|
||||
Usage: ptardiff ARCHIVE_FILE
|
||||
ptardiff -h
|
||||
|
||||
ptardiff is a small program that diffs an extracted archive
|
||||
against an unextracted one, using the perl module Archive::Tar.
|
||||
|
||||
This effectively lets you view changes made to an archives contents.
|
||||
|
||||
Provide the progam with an ARCHIVE_FILE and it will look up all
|
||||
the files with in the archive, scan the current working directory
|
||||
for a file with the name and diff it against the contents of the
|
||||
archive.
|
||||
|
||||
|
||||
Options:
|
||||
h Prints this help message
|
||||
|
||||
|
||||
Sample Usage:
|
||||
|
||||
$ tar -xzf Acme-Buffy-1.3.tar.gz
|
||||
$ vi Acme-Buffy-1.3/README
|
||||
|
||||
[...]
|
||||
|
||||
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
|
||||
|
||||
|
||||
See Also:
|
||||
tar(1)
|
||||
ptar
|
||||
Archive::Tar
|
||||
|
||||
] . $/;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptardiff - program that diffs an extracted archive against an unextracted one
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
ptardiff is a small program that diffs an extracted archive
|
||||
against an unextracted one, using the perl module Archive::Tar.
|
||||
|
||||
This effectively lets you view changes made to an archives contents.
|
||||
|
||||
Provide the progam with an ARCHIVE_FILE and it will look up all
|
||||
the files with in the archive, scan the current working directory
|
||||
for a file with the name and diff it against the contents of the
|
||||
archive.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptardiff ARCHIVE_FILE
|
||||
ptardiff -h
|
||||
|
||||
$ tar -xzf Acme-Buffy-1.3.tar.gz
|
||||
$ vi Acme-Buffy-1.3/README
|
||||
[...]
|
||||
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
|
||||
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
h Prints this help message
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
tar(1), L<Archive::Tar>.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,195 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!/usr/bin/perl
|
||||
##############################################################################
|
||||
# Tool for using regular expressions against the contents of files in a tar
|
||||
# archive. See 'ptargrep --help' for more documentation.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Pod::Usage qw(pod2usage);
|
||||
use Getopt::Long qw(GetOptions);
|
||||
use Archive::Tar qw();
|
||||
use File::Path qw(mkpath);
|
||||
|
||||
my(%opt, $pattern);
|
||||
|
||||
if(!GetOptions(\%opt,
|
||||
'basename|b',
|
||||
'ignore-case|i',
|
||||
'list-only|l',
|
||||
'verbose|v',
|
||||
'help|?',
|
||||
)) {
|
||||
pod2usage(-exitval => 1, -verbose => 0);
|
||||
}
|
||||
|
||||
|
||||
pod2usage(-exitstatus => 0, -verbose => 2) if $opt{help};
|
||||
|
||||
pod2usage(-exitval => 1, -verbose => 0,
|
||||
-message => "No pattern specified",
|
||||
) unless @ARGV;
|
||||
make_pattern( shift(@ARGV) );
|
||||
|
||||
pod2usage(-exitval => 1, -verbose => 0,
|
||||
-message => "No tar files specified",
|
||||
) unless @ARGV;
|
||||
|
||||
process_archive($_) foreach @ARGV;
|
||||
|
||||
exit 0;
|
||||
|
||||
|
||||
sub make_pattern {
|
||||
my($pat) = @_;
|
||||
|
||||
if($opt{'ignore-case'}) {
|
||||
$pattern = qr{(?im)$pat};
|
||||
}
|
||||
else {
|
||||
$pattern = qr{(?m)$pat};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub process_archive {
|
||||
my($filename) = @_;
|
||||
|
||||
_log("Processing archive: $filename");
|
||||
my $next = Archive::Tar->iter($filename);
|
||||
while( my $f = $next->() ) {
|
||||
next unless $f->is_file;
|
||||
match_file($f) if $f->size > 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub match_file {
|
||||
my($f) = @_;
|
||||
my $path = $f->name;
|
||||
my $prefix = $f->prefix;
|
||||
if (defined $prefix) {
|
||||
$path = File::Spec->catfile($prefix, $path);
|
||||
}
|
||||
|
||||
_log("filename: %s (%d bytes)", $path, $f->size);
|
||||
|
||||
my $body = $f->get_content();
|
||||
if($body !~ $pattern) {
|
||||
_log(" no match");
|
||||
return;
|
||||
}
|
||||
|
||||
if($opt{'list-only'}) {
|
||||
print $path, "\n";
|
||||
return;
|
||||
}
|
||||
|
||||
save_file($path, $body);
|
||||
}
|
||||
|
||||
|
||||
sub save_file {
|
||||
my($path, $body) = @_;
|
||||
|
||||
_log(" found match - extracting");
|
||||
my($fh);
|
||||
my($dir, $file) = $path =~ m{\A(?:(.*)/)?([^/]+)\z};
|
||||
if($dir and not $opt{basename}) {
|
||||
_log(" writing to $dir/$file");
|
||||
$dir =~ s{\A/}{./};
|
||||
mkpath($dir) unless -d $dir;
|
||||
open $fh, '>', "$dir/$file" or die "open($dir/$file): $!";
|
||||
}
|
||||
else {
|
||||
_log(" writing to ./$file");
|
||||
open $fh, '>', $file or die "open($file): $!";
|
||||
}
|
||||
print $fh $body;
|
||||
close($fh);
|
||||
}
|
||||
|
||||
|
||||
sub _log {
|
||||
return unless $opt{verbose};
|
||||
my($format, @args) = @_;
|
||||
warn sprintf($format, @args) . "\n";
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ptargrep - Apply pattern matching to the contents of files in a tar archive
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
ptargrep [options] <pattern> <tar file> ...
|
||||
|
||||
Options:
|
||||
|
||||
--basename|-b ignore directory paths from archive
|
||||
--ignore-case|-i do case-insensitive pattern matching
|
||||
--list-only|-l list matching filenames rather than extracting matches
|
||||
--verbose|-v write debugging message to STDERR
|
||||
--help|-? detailed help message
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This utility allows you to apply pattern matching to B<the contents> of files
|
||||
contained in a tar archive. You might use this to identify all files in an
|
||||
archive which contain lines matching the specified pattern and either print out
|
||||
the pathnames or extract the files.
|
||||
|
||||
The pattern will be used as a Perl regular expression (as opposed to a simple
|
||||
grep regex).
|
||||
|
||||
Multiple tar archive filenames can be specified - they will each be processed
|
||||
in turn.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<--basename> (alias -b)
|
||||
|
||||
When matching files are extracted, ignore the directory path from the archive
|
||||
and write to the current directory using the basename of the file from the
|
||||
archive. Beware: if two matching files in the archive have the same basename,
|
||||
the second file extracted will overwrite the first.
|
||||
|
||||
=item B<--ignore-case> (alias -i)
|
||||
|
||||
Make pattern matching case-insensitive.
|
||||
|
||||
=item B<--list-only> (alias -l)
|
||||
|
||||
Print the pathname of each matching file from the archive to STDOUT. Without
|
||||
this option, the default behaviour is to extract each matching file.
|
||||
|
||||
=item B<--verbose> (alias -v)
|
||||
|
||||
Log debugging info to STDERR.
|
||||
|
||||
=item B<--help> (alias -?)
|
||||
|
||||
Display this documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2010 Grant McLean E<lt>grantm@cpan.orgE<gt>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,332 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!perl
|
||||
|
||||
## shasum: filter for computing SHA digests (ref. sha1sum/md5sum)
|
||||
##
|
||||
## Copyright (C) 2003-2015 Mark Shelor, All Rights Reserved
|
||||
##
|
||||
## Version: 5.95
|
||||
## Sat Jan 10 12:15:36 MST 2015
|
||||
|
||||
## shasum SYNOPSIS adapted from GNU Coreutils sha1sum. Add
|
||||
## "-a" option for algorithm selection,
|
||||
## "-U" option for Universal Newlines support,
|
||||
## "-0" option for reading bit strings, and
|
||||
## "-p" option for portable digests (to be deprecated).
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Fcntl;
|
||||
use Getopt::Long;
|
||||
|
||||
my $POD = <<'END_OF_POD';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
shasum - Print or Check SHA Checksums
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Usage: shasum [OPTION]... [FILE]...
|
||||
Print or check SHA checksums.
|
||||
With no FILE, or when FILE is -, read standard input.
|
||||
|
||||
-a, --algorithm 1 (default), 224, 256, 384, 512, 512224, 512256
|
||||
-b, --binary read in binary mode
|
||||
-c, --check read SHA sums from the FILEs and check them
|
||||
-t, --text read in text mode (default)
|
||||
-U, --UNIVERSAL read in Universal Newlines mode
|
||||
produces same digest on Windows/Unix/Mac
|
||||
-0, --01 read in BITS mode
|
||||
ASCII '0' interpreted as 0-bit,
|
||||
ASCII '1' interpreted as 1-bit,
|
||||
all other characters ignored
|
||||
-p, --portable read in portable mode (to be deprecated)
|
||||
|
||||
The following two options are useful only when verifying checksums:
|
||||
-s, --status don't output anything, status code shows success
|
||||
-w, --warn warn about improperly formatted checksum lines
|
||||
|
||||
-h, --help display this help and exit
|
||||
-v, --version output version information and exit
|
||||
|
||||
When verifying SHA-512/224 or SHA-512/256 checksums, indicate the
|
||||
algorithm explicitly using the -a option, e.g.
|
||||
|
||||
shasum -a 512224 -c checksumfile
|
||||
|
||||
The sums are computed as described in FIPS PUB 180-4. When checking,
|
||||
the input should be a former output of this program. The default
|
||||
mode is to print a line with checksum, a character indicating type
|
||||
(`*' for binary, ` ' for text, `U' for UNIVERSAL, `^' for BITS, `?'
|
||||
for portable), and name for each FILE.
|
||||
|
||||
Report shasum bugs to mshelor@cpan.org
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Running I<shasum> is often the quickest way to compute SHA message
|
||||
digests. The user simply feeds data to the script through files or
|
||||
standard input, and then collects the results from standard output.
|
||||
|
||||
The following command shows how to compute digests for typical inputs
|
||||
such as the NIST test vector "abc":
|
||||
|
||||
perl -e "print qq(abc)" | shasum
|
||||
|
||||
Or, if you want to use SHA-256 instead of the default SHA-1, simply say:
|
||||
|
||||
perl -e "print qq(abc)" | shasum -a 256
|
||||
|
||||
Since I<shasum> mimics the behavior of the combined GNU I<sha1sum>,
|
||||
I<sha224sum>, I<sha256sum>, I<sha384sum>, and I<sha512sum> programs,
|
||||
you can install this script as a convenient drop-in replacement.
|
||||
|
||||
Unlike the GNU programs, I<shasum> encompasses the full SHA standard by
|
||||
allowing partial-byte inputs. This is accomplished through the BITS
|
||||
option (I<-0>). The following example computes the SHA-224 digest of
|
||||
the 7-bit message I<0001100>:
|
||||
|
||||
perl -e "print qq(0001100)" | shasum -0 -a 224
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright (c) 2003-2015 Mark Shelor <mshelor@cpan.org>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
I<shasum> is implemented using the Perl module L<Digest::SHA> or
|
||||
L<Digest::SHA::PurePerl>.
|
||||
|
||||
=cut
|
||||
|
||||
END_OF_POD
|
||||
|
||||
my $VERSION = "5.95";
|
||||
|
||||
sub usage {
|
||||
my($err, $msg) = @_;
|
||||
|
||||
$msg = "" unless defined $msg;
|
||||
if ($err) {
|
||||
warn($msg . "Type shasum -h for help\n");
|
||||
exit($err);
|
||||
}
|
||||
my($USAGE) = $POD =~ /SYNOPSIS(.+?)^=/sm;
|
||||
$USAGE =~ s/^\s*//;
|
||||
$USAGE =~ s/\s*$//;
|
||||
$USAGE =~ s/^ //gm;
|
||||
print $USAGE, "\n";
|
||||
exit($err);
|
||||
}
|
||||
|
||||
|
||||
## Sync stdout and stderr by forcing a flush after every write
|
||||
|
||||
select((select(STDOUT), $| = 1)[0]);
|
||||
select((select(STDERR), $| = 1)[0]);
|
||||
|
||||
|
||||
## Collect options from command line
|
||||
|
||||
my ($alg, $binary, $check, $text, $status, $warn, $help, $version);
|
||||
my ($portable, $BITS, $reverse, $UNIVERSAL, $versions);
|
||||
|
||||
eval { Getopt::Long::Configure ("bundling") };
|
||||
GetOptions(
|
||||
'b|binary' => \$binary, 'c|check' => \$check,
|
||||
't|text' => \$text, 'a|algorithm=i' => \$alg,
|
||||
's|status' => \$status, 'w|warn' => \$warn,
|
||||
'h|help' => \$help, 'v|version' => \$version,
|
||||
'p|portable' => \$portable,
|
||||
'0|01' => \$BITS,
|
||||
'R|REVERSE' => \$reverse,
|
||||
'U|UNIVERSAL' => \$UNIVERSAL,
|
||||
'V|VERSIONS' => \$versions,
|
||||
) or usage(1, "");
|
||||
|
||||
|
||||
## Deal with help requests and incorrect uses
|
||||
|
||||
usage(0)
|
||||
if $help;
|
||||
usage(1, "shasum: Ambiguous file mode\n")
|
||||
if scalar(grep {defined $_}
|
||||
($binary, $portable, $text, $BITS, $UNIVERSAL)) > 1;
|
||||
usage(1, "shasum: --warn option used only when verifying checksums\n")
|
||||
if $warn && !$check;
|
||||
usage(1, "shasum: --status option used only when verifying checksums\n")
|
||||
if $status && !$check;
|
||||
|
||||
|
||||
## Try to use Digest::SHA. If not installed, use the slower
|
||||
## but functionally equivalent Digest::SHA::PurePerl instead.
|
||||
|
||||
## If option -R is invoked, reverse the module preference,
|
||||
## i.e. try Digest::SHA::PurePerl first, then Digest::SHA.
|
||||
|
||||
my @MODS = qw(Digest::SHA Digest::SHA::PurePerl);
|
||||
@MODS[0, 1] = @MODS[1, 0] if $reverse;
|
||||
|
||||
my $module;
|
||||
for (@MODS) {
|
||||
my $mod = $_;
|
||||
if (eval "require $mod") {
|
||||
$module = $mod;
|
||||
last;
|
||||
}
|
||||
}
|
||||
die "shasum: Unable to find " . join(" or ", @MODS) . "\n"
|
||||
unless defined $module;
|
||||
|
||||
|
||||
## Default to SHA-1 unless overridden by command line option
|
||||
|
||||
$alg = 1 unless defined $alg;
|
||||
grep { $_ == $alg } (1, 224, 256, 384, 512, 512224, 512256)
|
||||
or usage(1, "shasum: Unrecognized algorithm\n");
|
||||
|
||||
|
||||
## Display version information if requested
|
||||
|
||||
if ($version) {
|
||||
print "$VERSION\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
if ($versions) {
|
||||
print "shasum $VERSION\n";
|
||||
print "$module ", eval "\$${module}::VERSION", "\n";
|
||||
print "perl ", defined $^V ? sprintf("%vd", $^V) : $], "\n";
|
||||
exit(0);
|
||||
}
|
||||
|
||||
|
||||
## Try to figure out if the OS is DOS-like. If it is,
|
||||
## default to binary mode when reading files, unless
|
||||
## explicitly overridden by command line "--text" or
|
||||
## "--UNIVERSAL" or "--portable" options.
|
||||
|
||||
my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin)$/);
|
||||
if ($isDOSish) { $binary = 1 unless $text || $UNIVERSAL || $portable }
|
||||
|
||||
my $modesym = $binary ? '*' : ($UNIVERSAL ? 'U' :
|
||||
($BITS ? '^' : ($portable ? '?' : ' ')));
|
||||
|
||||
|
||||
## Read from STDIN (-) if no files listed on command line
|
||||
|
||||
@ARGV = ("-") unless @ARGV;
|
||||
|
||||
|
||||
## sumfile($file): computes SHA digest of $file
|
||||
|
||||
sub sumfile {
|
||||
my $file = shift;
|
||||
|
||||
my $mode = $binary ? 'b' : ($UNIVERSAL ? 'U' :
|
||||
($BITS ? '0' : ($portable ? 'p' : '')));
|
||||
my $digest = eval { $module->new($alg)->addfile($file, $mode) };
|
||||
if ($@) { warn "shasum: $file: $!\n"; return }
|
||||
$digest->hexdigest;
|
||||
}
|
||||
|
||||
|
||||
## %len2alg: maps hex digest length to SHA algorithm
|
||||
|
||||
my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512);
|
||||
$len2alg{56} = 512224 if $alg == 512224;
|
||||
$len2alg{64} = 512256 if $alg == 512256;
|
||||
|
||||
|
||||
## unescape: convert backslashed filename to plain filename
|
||||
|
||||
sub unescape {
|
||||
$_ = shift;
|
||||
s/\\\\/\0/g;
|
||||
s/\\n/\n/g;
|
||||
return if /\\/;
|
||||
s/\0/\\/g;
|
||||
return $_;
|
||||
}
|
||||
|
||||
|
||||
## verify: confirm the digest values in a checksum file
|
||||
|
||||
sub verify {
|
||||
my $checkfile = shift;
|
||||
my ($err, $fmt_errs, $read_errs, $match_errs) = (0, 0, 0, 0);
|
||||
my ($num_lines, $num_files) = (0, 0);
|
||||
my ($bslash, $sum, $fname, $rsp, $digest);
|
||||
|
||||
local *FH;
|
||||
$checkfile eq '-' and open(FH, '< -')
|
||||
and $checkfile = 'standard input'
|
||||
or sysopen(FH, $checkfile, O_RDONLY)
|
||||
or die "shasum: $checkfile: $!\n";
|
||||
while (<FH>) {
|
||||
next if /^#/; s/\n$//; s/^[ \t]+//; $num_lines++;
|
||||
$bslash = s/^\\//;
|
||||
($sum, $modesym, $fname) =
|
||||
/^([\da-fA-F]+)[ \t]([ *?^U])([^\0]*)/;
|
||||
$alg = defined $sum ? $len2alg{length($sum)} : undef;
|
||||
$fname = unescape($fname) if defined $fname && $bslash;
|
||||
if (grep { ! defined $_ } ($alg, $sum, $modesym, $fname)) {
|
||||
$alg = 1 unless defined $alg;
|
||||
warn("shasum: $checkfile: $.: improperly " .
|
||||
"formatted SHA$alg checksum line\n") if $warn;
|
||||
$fmt_errs++;
|
||||
next;
|
||||
}
|
||||
$fname =~ s/\r$// unless -e $fname;
|
||||
$rsp = "$fname: "; $num_files++;
|
||||
($binary, $text, $UNIVERSAL, $BITS, $portable) =
|
||||
map { $_ eq $modesym } ('*', ' ', 'U', '^', 'p');
|
||||
unless ($digest = sumfile($fname)) {
|
||||
$rsp .= "FAILED open or read\n";
|
||||
$err = 1; $read_errs++;
|
||||
}
|
||||
else {
|
||||
if (lc($sum) eq $digest) { $rsp .= "OK\n" }
|
||||
else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
|
||||
}
|
||||
print $rsp unless $status;
|
||||
}
|
||||
close(FH);
|
||||
unless ($num_files) {
|
||||
$alg = 1 unless defined $alg;
|
||||
warn("shasum: $checkfile: no properly formatted " .
|
||||
"SHA$alg checksum lines found\n");
|
||||
$err = 1;
|
||||
}
|
||||
elsif (! $status) {
|
||||
warn("shasum: WARNING: $fmt_errs line" . ($fmt_errs>1?
|
||||
's are':' is') . " improperly formatted\n") if $fmt_errs;
|
||||
warn("shasum: WARNING: $read_errs listed file" .
|
||||
($read_errs>1?'s':'') . " could not be read\n") if $read_errs;
|
||||
warn("shasum: WARNING: $match_errs computed checksum" .
|
||||
($match_errs>1?'s':'') . " did NOT match\n") if $match_errs;
|
||||
}
|
||||
return($err == 0);
|
||||
}
|
||||
|
||||
|
||||
## Verify or compute SHA checksums of requested files
|
||||
|
||||
my($file, $digest);
|
||||
|
||||
my $STATUS = 0;
|
||||
for $file (@ARGV) {
|
||||
if ($check) { $STATUS = 1 unless verify($file) }
|
||||
elsif ($digest = sumfile($file)) {
|
||||
if ($file =~ /[\n\\]/) {
|
||||
$file =~ s/\\/\\\\/g; $file =~ s/\n/\\n/g;
|
||||
$digest = "\\$digest";
|
||||
}
|
||||
print "$digest $modesym", "$file\n";
|
||||
}
|
||||
else { $STATUS = 1 }
|
||||
}
|
||||
exit($STATUS)
|
||||
|
|
@ -0,0 +1,706 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
diagnostics, splain - produce verbose warning diagnostics
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Using the C<diagnostics> pragma:
|
||||
|
||||
use diagnostics;
|
||||
use diagnostics -verbose;
|
||||
|
||||
enable diagnostics;
|
||||
disable diagnostics;
|
||||
|
||||
Using the C<splain> standalone filter program:
|
||||
|
||||
perl program 2>diag.out
|
||||
splain [-v] [-p] diag.out
|
||||
|
||||
Using diagnostics to get stack traces from a misbehaving script:
|
||||
|
||||
perl -Mdiagnostics=-traceonly my_script.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 The C<diagnostics> Pragma
|
||||
|
||||
This module extends the terse diagnostics normally emitted by both the
|
||||
perl compiler and the perl interpreter (from running perl with a -w
|
||||
switch or C<use warnings>), augmenting them with the more
|
||||
explicative and endearing descriptions found in L<perldiag>. Like the
|
||||
other pragmata, it affects the compilation phase of your program rather
|
||||
than merely the execution phase.
|
||||
|
||||
To use in your program as a pragma, merely invoke
|
||||
|
||||
use diagnostics;
|
||||
|
||||
at the start (or near the start) of your program. (Note
|
||||
that this I<does> enable perl's B<-w> flag.) Your whole
|
||||
compilation will then be subject(ed :-) to the enhanced diagnostics.
|
||||
These still go out B<STDERR>.
|
||||
|
||||
Due to the interaction between runtime and compiletime issues,
|
||||
and because it's probably not a very good idea anyway,
|
||||
you may not use C<no diagnostics> to turn them off at compiletime.
|
||||
However, you may control their behaviour at runtime using the
|
||||
disable() and enable() methods to turn them off and on respectively.
|
||||
|
||||
The B<-verbose> flag first prints out the L<perldiag> introduction before
|
||||
any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
|
||||
escape sequences for pagers.
|
||||
|
||||
Warnings dispatched from perl itself (or more accurately, those that match
|
||||
descriptions found in L<perldiag>) are only displayed once (no duplicate
|
||||
descriptions). User code generated warnings a la warn() are unaffected,
|
||||
allowing duplicate user messages to be displayed.
|
||||
|
||||
This module also adds a stack trace to the error message when perl dies.
|
||||
This is useful for pinpointing what
|
||||
caused the death. The B<-traceonly> (or
|
||||
just B<-t>) flag turns off the explanations of warning messages leaving just
|
||||
the stack traces. So if your script is dieing, run it again with
|
||||
|
||||
perl -Mdiagnostics=-traceonly my_bad_script
|
||||
|
||||
to see the call stack at the time of death. By supplying the B<-warntrace>
|
||||
(or just B<-w>) flag, any warnings emitted will also come with a stack
|
||||
trace.
|
||||
|
||||
=head2 The I<splain> Program
|
||||
|
||||
While apparently a whole nuther program, I<splain> is actually nothing
|
||||
more than a link to the (executable) F<diagnostics.pm> module, as well as
|
||||
a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
|
||||
the C<use diagnostics -verbose> directive.
|
||||
The B<-p> flag is like the
|
||||
$diagnostics::PRETTY variable. Since you're post-processing with
|
||||
I<splain>, there's no sense in being able to enable() or disable() processing.
|
||||
|
||||
Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
The following file is certain to trigger a few errors at both
|
||||
runtime and compiletime:
|
||||
|
||||
use diagnostics;
|
||||
print NOWHERE "nothing\n";
|
||||
print STDERR "\n\tThis message should be unadorned.\n";
|
||||
warn "\tThis is a user warning";
|
||||
print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
|
||||
my $a, $b = scalar <STDIN>;
|
||||
print "\n";
|
||||
print $x/$y;
|
||||
|
||||
If you prefer to run your program first and look at its problem
|
||||
afterwards, do this:
|
||||
|
||||
perl -w test.pl 2>test.out
|
||||
./splain < test.out
|
||||
|
||||
Note that this is not in general possible in shells of more dubious heritage,
|
||||
as the theoretical
|
||||
|
||||
(perl -w test.pl >/dev/tty) >& test.out
|
||||
./splain < test.out
|
||||
|
||||
Because you just moved the existing B<stdout> to somewhere else.
|
||||
|
||||
If you don't want to modify your source code, but still have on-the-fly
|
||||
warnings, do this:
|
||||
|
||||
exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
|
||||
|
||||
Nifty, eh?
|
||||
|
||||
If you want to control warnings on the fly, do something like this.
|
||||
Make sure you do the C<use> first, or you won't be able to get
|
||||
at the enable() or disable() methods.
|
||||
|
||||
use diagnostics; # checks entire compilation phase
|
||||
print "\ntime for 1st bogus diags: SQUAWKINGS\n";
|
||||
print BOGUS1 'nada';
|
||||
print "done with 1st bogus\n";
|
||||
|
||||
disable diagnostics; # only turns off runtime warnings
|
||||
print "\ntime for 2nd bogus: (squelched)\n";
|
||||
print BOGUS2 'nada';
|
||||
print "done with 2nd bogus\n";
|
||||
|
||||
enable diagnostics; # turns back on runtime warnings
|
||||
print "\ntime for 3rd bogus: SQUAWKINGS\n";
|
||||
print BOGUS3 'nada';
|
||||
print "done with 3rd bogus\n";
|
||||
|
||||
disable diagnostics;
|
||||
print "\ntime for 4th bogus: (squelched)\n";
|
||||
print BOGUS4 'nada';
|
||||
print "done with 4th bogus\n";
|
||||
|
||||
=head1 INTERNALS
|
||||
|
||||
Diagnostic messages derive from the F<perldiag.pod> file when available at
|
||||
runtime. Otherwise, they may be embedded in the file itself when the
|
||||
splain package is built. See the F<Makefile> for details.
|
||||
|
||||
If an extant $SIG{__WARN__} handler is discovered, it will continue
|
||||
to be honored, but only after the diagnostics::splainthis() function
|
||||
(the module's $SIG{__WARN__} interceptor) has had its way with your
|
||||
warnings.
|
||||
|
||||
There is a $diagnostics::DEBUG variable you may set if you're desperately
|
||||
curious what sorts of things are being intercepted.
|
||||
|
||||
BEGIN { $diagnostics::DEBUG = 1 }
|
||||
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Not being able to say "no diagnostics" is annoying, but may not be
|
||||
insurmountable.
|
||||
|
||||
The C<-pretty> directive is called too late to affect matters.
|
||||
You have to do this instead, and I<before> you load the module.
|
||||
|
||||
BEGIN { $diagnostics::PRETTY = 1 }
|
||||
|
||||
I could start up faster by delaying compilation until it should be
|
||||
needed, but this gets a "panic: top_level" when using the pragma form
|
||||
in Perl 5.001e.
|
||||
|
||||
While it's true that this documentation is somewhat subserious, if you use
|
||||
a program named I<splain>, you should expect a bit of whimsy.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use 5.009001;
|
||||
use Carp;
|
||||
$Carp::Internal{__PACKAGE__.""}++;
|
||||
|
||||
our $VERSION = '1.34';
|
||||
our $DEBUG;
|
||||
our $VERBOSE;
|
||||
our $PRETTY;
|
||||
our $TRACEONLY = 0;
|
||||
our $WARNTRACE = 0;
|
||||
|
||||
use Config;
|
||||
use Text::Tabs 'expand';
|
||||
my $privlib = $Config{privlibexp};
|
||||
if ($^O eq 'VMS') {
|
||||
require VMS::Filespec;
|
||||
$privlib = VMS::Filespec::unixify($privlib);
|
||||
}
|
||||
my @trypod = (
|
||||
"$privlib/pod/perldiag.pod",
|
||||
"$privlib/pods/perldiag.pod",
|
||||
);
|
||||
# handy for development testing of new warnings etc
|
||||
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
|
||||
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
|
||||
|
||||
$DEBUG ||= 0;
|
||||
|
||||
local $| = 1;
|
||||
local $_;
|
||||
local $.;
|
||||
|
||||
my $standalone;
|
||||
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
|
||||
|
||||
CONFIG: {
|
||||
our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
|
||||
|
||||
unless (caller) {
|
||||
$standalone++;
|
||||
require Getopt::Std;
|
||||
Getopt::Std::getopts('pdvf:')
|
||||
or die "Usage: $0 [-v] [-p] [-f splainpod]";
|
||||
$PODFILE = $opt_f if $opt_f;
|
||||
$DEBUG = 2 if $opt_d;
|
||||
$VERBOSE = $opt_v;
|
||||
$PRETTY = $opt_p;
|
||||
}
|
||||
|
||||
if (open(POD_DIAG, $PODFILE)) {
|
||||
warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
|
||||
last CONFIG;
|
||||
}
|
||||
|
||||
if (caller) {
|
||||
INCPATH: {
|
||||
for my $file ( (map { "$_/".__PACKAGE__.".pm" } @INC), $0) {
|
||||
warn "Checking $file\n" if $DEBUG;
|
||||
if (open(POD_DIAG, $file)) {
|
||||
while (<POD_DIAG>) {
|
||||
next unless
|
||||
/^__END__\s*# wish diag dbase were more accessible/;
|
||||
print STDERR "podfile is $file\n" if $DEBUG;
|
||||
last INCPATH;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
print STDERR "podfile is <DATA>\n" if $DEBUG;
|
||||
*POD_DIAG = *main::DATA;
|
||||
}
|
||||
}
|
||||
if (eof(POD_DIAG)) {
|
||||
die "couldn't find diagnostic data in $PODFILE @INC $0";
|
||||
}
|
||||
|
||||
|
||||
%HTML_2_Troff = (
|
||||
'amp' => '&', # ampersand
|
||||
'lt' => '<', # left chevron, less-than
|
||||
'gt' => '>', # right chevron, greater-than
|
||||
'quot' => '"', # double quote
|
||||
|
||||
"Aacute" => "A\\*'", # capital A, acute accent
|
||||
# etc
|
||||
|
||||
);
|
||||
|
||||
%HTML_2_Latin_1 = (
|
||||
'amp' => '&', # ampersand
|
||||
'lt' => '<', # left chevron, less-than
|
||||
'gt' => '>', # right chevron, greater-than
|
||||
'quot' => '"', # double quote
|
||||
|
||||
"Aacute" => "\xC1" # capital A, acute accent
|
||||
|
||||
# etc
|
||||
);
|
||||
|
||||
%HTML_2_ASCII_7 = (
|
||||
'amp' => '&', # ampersand
|
||||
'lt' => '<', # left chevron, less-than
|
||||
'gt' => '>', # right chevron, greater-than
|
||||
'quot' => '"', # double quote
|
||||
|
||||
"Aacute" => "A" # capital A, acute accent
|
||||
# etc
|
||||
);
|
||||
|
||||
our %HTML_Escapes;
|
||||
*HTML_Escapes = do {
|
||||
if ($standalone) {
|
||||
$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
|
||||
} else {
|
||||
\%HTML_2_Latin_1;
|
||||
}
|
||||
};
|
||||
|
||||
*THITHER = $standalone ? *STDOUT : *STDERR;
|
||||
|
||||
my %transfmt = ();
|
||||
my $transmo = <<EOFUNC;
|
||||
sub transmo {
|
||||
#local \$^W = 0; # recursive warnings we do NOT need!
|
||||
EOFUNC
|
||||
|
||||
my %msg;
|
||||
{
|
||||
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
|
||||
local $/ = '';
|
||||
local $_;
|
||||
my $header;
|
||||
my @headers;
|
||||
my $for_item;
|
||||
my $seen_body;
|
||||
while (<POD_DIAG>) {
|
||||
|
||||
sub _split_pod_link {
|
||||
$_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s;
|
||||
($1,$2,$4);
|
||||
}
|
||||
|
||||
unescape();
|
||||
if ($PRETTY) {
|
||||
sub noop { return $_[0] } # spensive for a noop
|
||||
sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
|
||||
sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
|
||||
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
|
||||
s/[IF]<(.*?)>/italic($1)/ges;
|
||||
s/L<(.*?)>/
|
||||
my($text,$page,$sect) = _split_pod_link($1);
|
||||
defined $text
|
||||
? $text
|
||||
: defined $sect
|
||||
? italic($sect) . ' in ' . italic($page)
|
||||
: italic($page)
|
||||
/ges;
|
||||
s/S<(.*?)>/
|
||||
$1
|
||||
/ges;
|
||||
} else {
|
||||
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
|
||||
s/[IF]<(.*?)>/$1/gs;
|
||||
s/L<(.*?)>/
|
||||
my($text,$page,$sect) = _split_pod_link($1);
|
||||
defined $text
|
||||
? $text
|
||||
: defined $sect
|
||||
? qq '"$sect" in $page'
|
||||
: $page
|
||||
/ges;
|
||||
s/S<(.*?)>/
|
||||
$1
|
||||
/ges;
|
||||
}
|
||||
unless (/^=/) {
|
||||
if (defined $header) {
|
||||
if ( $header eq 'DESCRIPTION' &&
|
||||
( /Optional warnings are enabled/
|
||||
|| /Some of these messages are generic./
|
||||
) )
|
||||
{
|
||||
next;
|
||||
}
|
||||
$_ = expand $_;
|
||||
s/^/ /gm;
|
||||
$msg{$header} .= $_;
|
||||
for my $h(@headers) { $msg{$h} .= $_ }
|
||||
++$seen_body;
|
||||
undef $for_item;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
# If we have not come across the body of the description yet, then
|
||||
# the previous header needs to share the same description.
|
||||
if ($seen_body) {
|
||||
@headers = ();
|
||||
}
|
||||
else {
|
||||
push @headers, $header if defined $header;
|
||||
}
|
||||
|
||||
unless ( s/=item (.*?)\s*\z//s) {
|
||||
|
||||
if ( s/=head1\sDESCRIPTION//) {
|
||||
$msg{$header = 'DESCRIPTION'} = '';
|
||||
undef $for_item;
|
||||
}
|
||||
elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
|
||||
$for_item = $1;
|
||||
}
|
||||
elsif( /^=back/ ) { # Stop processing body here
|
||||
undef $header;
|
||||
undef $for_item;
|
||||
$seen_body = 0;
|
||||
next;
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
if( $for_item ) { $header = $for_item; undef $for_item }
|
||||
else {
|
||||
$header = $1;
|
||||
|
||||
$header =~ s/\n/ /gs; # Allow multi-line headers
|
||||
}
|
||||
|
||||
# strip formatting directives from =item line
|
||||
$header =~ s/[A-Z]<(.*?)>/$1/g;
|
||||
|
||||
# Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
|
||||
$header =~ s/(\.\s*)?$//;
|
||||
|
||||
my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
|
||||
if (@toks > 1) {
|
||||
my $conlen = 0;
|
||||
for my $i (0..$#toks){
|
||||
if( $i % 2 ){
|
||||
if( $toks[$i] eq '%c' ){
|
||||
$toks[$i] = '.';
|
||||
} elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
|
||||
$toks[$i] = '\d+';
|
||||
} elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
|
||||
$toks[$i] = $i == $#toks ? '.*' : '.*?';
|
||||
} elsif( $toks[$i] =~ '%.(\d+)s' ){
|
||||
$toks[$i] = ".{$1}";
|
||||
} elsif( $toks[$i] =~ '^%l*([pxX])$' ){
|
||||
$toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
|
||||
}
|
||||
} elsif( length( $toks[$i] ) ){
|
||||
$toks[$i] = quotemeta $toks[$i];
|
||||
$conlen += length( $toks[$i] );
|
||||
}
|
||||
}
|
||||
my $lhs = join( '', @toks );
|
||||
$lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
|
||||
$transfmt{$header}{pat} =
|
||||
" s^\\s*$lhs\\s*\Q$header\Es\n\t&& return 1;\n";
|
||||
$transfmt{$header}{len} = $conlen;
|
||||
} else {
|
||||
my $lhs = "\Q$header\E";
|
||||
$lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
|
||||
$transfmt{$header}{pat} =
|
||||
" s^\\s*$lhs\\s*\Q$header\E\n\t && return 1;\n";
|
||||
$transfmt{$header}{len} = length( $header );
|
||||
}
|
||||
|
||||
print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n"
|
||||
if $msg{$header};
|
||||
|
||||
$msg{$header} = '';
|
||||
$seen_body = 0;
|
||||
}
|
||||
|
||||
|
||||
close POD_DIAG unless *main::DATA eq *POD_DIAG;
|
||||
|
||||
die "No diagnostics?" unless %msg;
|
||||
|
||||
# Apply patterns in order of decreasing sum of lengths of fixed parts
|
||||
# Seems the best way of hitting the right one.
|
||||
for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
|
||||
keys %transfmt ){
|
||||
$transmo .= $transfmt{$hdr}{pat};
|
||||
}
|
||||
$transmo .= " return 0;\n}\n";
|
||||
print STDERR $transmo if $DEBUG;
|
||||
eval $transmo;
|
||||
die $@ if $@;
|
||||
}
|
||||
|
||||
if ($standalone) {
|
||||
if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
|
||||
while (defined (my $error = <>)) {
|
||||
splainthis($error) || print THITHER $error;
|
||||
}
|
||||
exit;
|
||||
}
|
||||
|
||||
my $olddie;
|
||||
my $oldwarn;
|
||||
|
||||
sub import {
|
||||
shift;
|
||||
$^W = 1; # yup, clobbered the global variable;
|
||||
# tough, if you want diags, you want diags.
|
||||
return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
|
||||
|
||||
for (@_) {
|
||||
|
||||
/^-d(ebug)?$/ && do {
|
||||
$DEBUG++;
|
||||
next;
|
||||
};
|
||||
|
||||
/^-v(erbose)?$/ && do {
|
||||
$VERBOSE++;
|
||||
next;
|
||||
};
|
||||
|
||||
/^-p(retty)?$/ && do {
|
||||
print STDERR "$0: I'm afraid it's too late for prettiness.\n";
|
||||
$PRETTY++;
|
||||
next;
|
||||
};
|
||||
# matches trace and traceonly for legacy doc mixup reasons
|
||||
/^-t(race(only)?)?$/ && do {
|
||||
$TRACEONLY++;
|
||||
next;
|
||||
};
|
||||
/^-w(arntrace)?$/ && do {
|
||||
$WARNTRACE++;
|
||||
next;
|
||||
};
|
||||
|
||||
warn "Unknown flag: $_";
|
||||
}
|
||||
|
||||
$oldwarn = $SIG{__WARN__};
|
||||
$olddie = $SIG{__DIE__};
|
||||
$SIG{__WARN__} = \&warn_trap;
|
||||
$SIG{__DIE__} = \&death_trap;
|
||||
}
|
||||
|
||||
sub enable { &import }
|
||||
|
||||
sub disable {
|
||||
shift;
|
||||
return unless $SIG{__WARN__} eq \&warn_trap;
|
||||
$SIG{__WARN__} = $oldwarn || '';
|
||||
$SIG{__DIE__} = $olddie || '';
|
||||
}
|
||||
|
||||
sub warn_trap {
|
||||
my $warning = $_[0];
|
||||
if (caller eq __PACKAGE__ or !splainthis($warning)) {
|
||||
if ($WARNTRACE) {
|
||||
print STDERR Carp::longmess($warning);
|
||||
} else {
|
||||
print STDERR $warning;
|
||||
}
|
||||
}
|
||||
goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
|
||||
};
|
||||
|
||||
sub death_trap {
|
||||
my $exception = $_[0];
|
||||
|
||||
# See if we are coming from anywhere within an eval. If so we don't
|
||||
# want to explain the exception because it's going to get caught.
|
||||
my $in_eval = 0;
|
||||
my $i = 0;
|
||||
while (my $caller = (caller($i++))[3]) {
|
||||
if ($caller eq '(eval)') {
|
||||
$in_eval = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
splainthis($exception) unless $in_eval;
|
||||
if (caller eq __PACKAGE__) {
|
||||
print STDERR "INTERNAL EXCEPTION: $exception";
|
||||
}
|
||||
&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
|
||||
|
||||
return if $in_eval;
|
||||
|
||||
# We don't want to unset these if we're coming from an eval because
|
||||
# then we've turned off diagnostics.
|
||||
|
||||
# Switch off our die/warn handlers so we don't wind up in our own
|
||||
# traps.
|
||||
$SIG{__DIE__} = $SIG{__WARN__} = '';
|
||||
|
||||
$exception =~ s/\n(?=.)/\n\t/gas;
|
||||
|
||||
die Carp::longmess("__diagnostics__")
|
||||
=~ s/^__diagnostics__.*?line \d+\.?\n/
|
||||
"Uncaught exception from user code:\n\t$exception"
|
||||
/re;
|
||||
# up we go; where we stop, nobody knows, but i think we die now
|
||||
# but i'm deeply afraid of the &$olddie guy reraising and us getting
|
||||
# into an indirect recursion loop
|
||||
};
|
||||
|
||||
my %exact_duplicate;
|
||||
my %old_diag;
|
||||
my $count;
|
||||
my $wantspace;
|
||||
sub splainthis {
|
||||
return 0 if $TRACEONLY;
|
||||
for (my $tmp = shift) {
|
||||
local $\;
|
||||
local $!;
|
||||
### &finish_compilation unless %msg;
|
||||
s/(\.\s*)?\n+$//;
|
||||
my $orig = $_;
|
||||
# return unless defined;
|
||||
|
||||
# get rid of the where-are-we-in-input part
|
||||
s/, <.*?> (?:line|chunk).*$//;
|
||||
|
||||
# Discard 1st " at <file> line <no>" and all text beyond
|
||||
# but be aware of messages containing " at this-or-that"
|
||||
my $real = 0;
|
||||
my @secs = split( / at / );
|
||||
return unless @secs;
|
||||
$_ = $secs[0];
|
||||
for my $i ( 1..$#secs ){
|
||||
if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
|
||||
$real = 1;
|
||||
last;
|
||||
} else {
|
||||
$_ .= ' at ' . $secs[$i];
|
||||
}
|
||||
}
|
||||
|
||||
# remove parenthesis occurring at the end of some messages
|
||||
s/^\((.*)\)$/$1/;
|
||||
|
||||
if ($exact_duplicate{$orig}++) {
|
||||
return &transmo;
|
||||
} else {
|
||||
return 0 unless &transmo;
|
||||
}
|
||||
|
||||
my $short = shorten($orig);
|
||||
if ($old_diag{$_}) {
|
||||
autodescribe();
|
||||
print THITHER "$short (#$old_diag{$_})\n";
|
||||
$wantspace = 1;
|
||||
} elsif (!$msg{$_} && $orig =~ /\n./s) {
|
||||
# A multiline message, like "Attempt to reload /
|
||||
# Compilation failed"
|
||||
my $found;
|
||||
for (split /^/, $orig) {
|
||||
splainthis($_) and $found = 1;
|
||||
}
|
||||
return $found;
|
||||
} else {
|
||||
autodescribe();
|
||||
$old_diag{$_} = ++$count;
|
||||
print THITHER "\n" if $wantspace;
|
||||
$wantspace = 0;
|
||||
print THITHER "$short (#$old_diag{$_})\n";
|
||||
if ($msg{$_}) {
|
||||
print THITHER $msg{$_};
|
||||
} else {
|
||||
if (0 and $standalone) {
|
||||
print THITHER " **** Error #$old_diag{$_} ",
|
||||
($real ? "is" : "appears to be"),
|
||||
" an unknown diagnostic message.\n\n";
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
sub autodescribe {
|
||||
if ($VERBOSE and not $count) {
|
||||
print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
|
||||
"\n$msg{DESCRIPTION}\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub unescape {
|
||||
s {
|
||||
E<
|
||||
( [A-Za-z]+ )
|
||||
>
|
||||
} {
|
||||
do {
|
||||
exists $HTML_Escapes{$1}
|
||||
? do { $HTML_Escapes{$1} }
|
||||
: do {
|
||||
warn "Unknown escape: E<$1> in $_";
|
||||
"E<$1>";
|
||||
}
|
||||
}
|
||||
}egx;
|
||||
}
|
||||
|
||||
sub shorten {
|
||||
my $line = $_[0];
|
||||
if (length($line) > 79 and index($line, "\n") == -1) {
|
||||
my $space_place = rindex($line, ' ', 79);
|
||||
if ($space_place != -1) {
|
||||
substr($line, $space_place, 1) = "\n\t";
|
||||
}
|
||||
}
|
||||
return $line;
|
||||
}
|
||||
|
||||
|
||||
1 unless $standalone; # or it'll complain about itself
|
||||
__END__ # wish diag dbase were more accessible
|
||||
|
|
@ -0,0 +1,187 @@
|
|||
#!/data/local/perl/bin/perl5.22.0
|
||||
eval 'exec /data/local/perl/bin/perl5.22.0 -S $0 ${1+"$@"}'
|
||||
if $running_under_some_shell;
|
||||
#!perl
|
||||
use 5.006;
|
||||
use strict;
|
||||
eval {
|
||||
require ExtUtils::ParseXS;
|
||||
1;
|
||||
}
|
||||
or do {
|
||||
my $err = $@ || 'Zombie error';
|
||||
my $v = $ExtUtils::ParseXS::VERSION;
|
||||
$v = '<undef>' if not defined $v;
|
||||
die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err";
|
||||
};
|
||||
|
||||
use Getopt::Long;
|
||||
|
||||
my %args = ();
|
||||
|
||||
my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|s pattern] [-typemap typemap]... file.xs\n";
|
||||
|
||||
Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case);
|
||||
|
||||
@ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility
|
||||
GetOptions(\%args, qw(hiertype!
|
||||
prototypes!
|
||||
versioncheck!
|
||||
linenumbers!
|
||||
optimize!
|
||||
inout!
|
||||
argtypes!
|
||||
object_capi!
|
||||
except!
|
||||
v
|
||||
typemap=s@
|
||||
output=s
|
||||
s|strip=s
|
||||
csuffix=s
|
||||
))
|
||||
or die $usage;
|
||||
|
||||
if ($args{v}) {
|
||||
print "xsubpp version $ExtUtils::ParseXS::VERSION\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
@ARGV == 1 or die $usage;
|
||||
|
||||
$args{filename} = shift @ARGV;
|
||||
|
||||
my $pxs = ExtUtils::ParseXS->new;
|
||||
$pxs->process_file(%args);
|
||||
exit( $pxs->report_error_count() ? 1 : 0 );
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
xsubpp - compiler to convert Perl XS code into C code
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>
|
||||
or by L<Module::Build> or other Perl module build tools.
|
||||
|
||||
I<xsubpp> will compile XS code into C code by embedding the constructs
|
||||
necessary to let C functions manipulate Perl values and creates the glue
|
||||
necessary to let Perl access those functions. The compiler uses typemaps to
|
||||
determine how to map C function parameters and variables to Perl values.
|
||||
|
||||
The compiler will search for typemap files called I<typemap>. It will use
|
||||
the following search path to find default typemaps, with the rightmost
|
||||
typemap taking precedence.
|
||||
|
||||
../../../typemap:../../typemap:../typemap:typemap
|
||||
|
||||
It will also use a default typemap installed as C<ExtUtils::typemap>.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
Note that the C<XSOPT> MakeMaker option may be used to add these options to
|
||||
any makefiles generated by MakeMaker.
|
||||
|
||||
=over 5
|
||||
|
||||
=item B<-hiertype>
|
||||
|
||||
Retains '::' in type names so that C++ hierarchical types can be mapped.
|
||||
|
||||
=item B<-except>
|
||||
|
||||
Adds exception handling stubs to the C code.
|
||||
|
||||
=item B<-typemap typemap>
|
||||
|
||||
Indicates that a user-supplied typemap should take precedence over the
|
||||
default typemaps. This option may be used multiple times, with the last
|
||||
typemap having the highest precedence.
|
||||
|
||||
=item B<-output filename>
|
||||
|
||||
Specifies the name of the output file to generate. If no file is
|
||||
specified, output will be written to standard output.
|
||||
|
||||
=item B<-v>
|
||||
|
||||
Prints the I<xsubpp> version number to standard output, then exits.
|
||||
|
||||
=item B<-prototypes>
|
||||
|
||||
By default I<xsubpp> will not automatically generate prototype code for
|
||||
all xsubs. This flag will enable prototypes.
|
||||
|
||||
=item B<-noversioncheck>
|
||||
|
||||
Disables the run time test that determines if the object file (derived
|
||||
from the C<.xs> file) and the C<.pm> files have the same version
|
||||
number.
|
||||
|
||||
=item B<-nolinenumbers>
|
||||
|
||||
Prevents the inclusion of '#line' directives in the output.
|
||||
|
||||
=item B<-nooptimize>
|
||||
|
||||
Disables certain optimizations. The only optimization that is currently
|
||||
affected is the use of I<target>s by the output C code (see L<perlguts>).
|
||||
This may significantly slow down the generated code, but this is the way
|
||||
B<xsubpp> of 5.005 and earlier operated.
|
||||
|
||||
=item B<-noinout>
|
||||
|
||||
Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.
|
||||
|
||||
=item B<-noargtypes>
|
||||
|
||||
Disable recognition of ANSI-like descriptions of function signature.
|
||||
|
||||
=item B<-C++>
|
||||
|
||||
Currently doesn't do anything at all. This flag has been a no-op for
|
||||
many versions of perl, at least as far back as perl5.003_07. It's
|
||||
allowed here for backwards compatibility.
|
||||
|
||||
=item B<-s=...> or B<-strip=...>
|
||||
|
||||
I<This option is obscure and discouraged.>
|
||||
|
||||
If specified, the given string will be stripped off from the beginning
|
||||
of the C function name in the generated XS functions (if it starts with that prefix).
|
||||
This only applies to XSUBs without C<CODE> or C<PPCODE> blocks.
|
||||
For example, the XS:
|
||||
|
||||
void foo_bar(int i);
|
||||
|
||||
when C<xsubpp> is invoked with C<-s foo_> will install a C<foo_bar>
|
||||
function in Perl, but really call C<bar(i)> in C. Most of the time,
|
||||
this is the opposite of what you want and failure modes are somewhat
|
||||
obscure, so please avoid this option where possible.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
No environment variables are used.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module
|
||||
by Ken Williams.
|
||||
|
||||
=head1 MODIFICATION HISTORY
|
||||
|
||||
See the file F<Changes>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS
|
||||
|
||||
=cut
|
||||
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,96 @@
|
|||
package AnyDBM_File;
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use 5.006_001;
|
||||
our $VERSION = '1.01';
|
||||
our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
|
||||
|
||||
my $mod;
|
||||
for $mod (@ISA) {
|
||||
if (eval "require $mod") {
|
||||
@ISA = ($mod); # if we leave @ISA alone, warnings abound
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
die "No DBM package was successfully found or installed";
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
AnyDBM_File - provide framework for multiple DBMs
|
||||
|
||||
NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use AnyDBM_File;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is a "pure virtual base class"--it has nothing of its own.
|
||||
It's just there to inherit from one of the various DBM packages. It
|
||||
prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See
|
||||
L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and
|
||||
finally ODBM. This way old programs that used to use NDBM via dbmopen()
|
||||
can still do so, but new ones can reorder @ISA:
|
||||
|
||||
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
|
||||
use AnyDBM_File;
|
||||
|
||||
Having multiple DBM implementations makes it trivial to copy database formats:
|
||||
|
||||
use Fcntl; use NDBM_File; use DB_File;
|
||||
tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
|
||||
tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
|
||||
%newhash = %oldhash;
|
||||
|
||||
=head2 DBM Comparisons
|
||||
|
||||
Here's a partial table of features the different packages offer:
|
||||
|
||||
odbm ndbm sdbm gdbm bsd-db
|
||||
---- ---- ---- ---- ------
|
||||
Linkage comes w/ perl yes yes yes yes yes
|
||||
Src comes w/ perl no no yes no no
|
||||
Comes w/ many unix os yes yes[0] no no no
|
||||
Builds ok on !unix ? ? yes yes ?
|
||||
Code Size ? ? small big big
|
||||
Database Size ? ? small big? ok[1]
|
||||
Speed ? ? slow ok fast
|
||||
FTPable no no yes yes yes
|
||||
Easy to build N/A N/A yes yes ok[2]
|
||||
Size limits 1k 4k 1k[3] none none
|
||||
Byte-order independent no no no no yes
|
||||
Licensing restrictions ? ? no yes no
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item [0]
|
||||
|
||||
on mixed universe machines, may be in the bsd compat library,
|
||||
which is often shunned.
|
||||
|
||||
=item [1]
|
||||
|
||||
Can be trimmed if you compile for one access method.
|
||||
|
||||
=item [2]
|
||||
|
||||
See L<DB_File>.
|
||||
Requires symbolic links.
|
||||
|
||||
=item [3]
|
||||
|
||||
By default, but can be redefined.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
dbm(3), ndbm(3), DB_File(3), L<perldbmfilter>
|
||||
|
||||
=cut
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,827 @@
|
|||
package App::Prove;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use TAP::Harness::Env;
|
||||
use Text::ParseWords qw(shellwords);
|
||||
use File::Spec;
|
||||
use Getopt::Long;
|
||||
use App::Prove::State;
|
||||
use Carp;
|
||||
|
||||
use base 'TAP::Object';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove - Implements the C<prove> command.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.35
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.35';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Test::Harness> provides a command, C<prove>, which runs a TAP based
|
||||
test suite and prints a report. The C<prove> command is a minimal
|
||||
wrapper around an instance of this module.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use App::Prove;
|
||||
|
||||
my $app = App::Prove->new;
|
||||
$app->process_args(@ARGV);
|
||||
$app->run;
|
||||
|
||||
=cut
|
||||
|
||||
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
|
||||
use constant IS_VMS => $^O eq 'VMS';
|
||||
use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
|
||||
|
||||
use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
|
||||
use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
|
||||
|
||||
use constant PLUGINS => 'App::Prove::Plugin';
|
||||
|
||||
my @ATTR;
|
||||
|
||||
BEGIN {
|
||||
@ATTR = qw(
|
||||
archive argv blib show_count color directives exec failures comments
|
||||
formatter harness includes modules plugins jobs lib merge parse quiet
|
||||
really_quiet recurse backwards shuffle taint_fail taint_warn timer
|
||||
verbose warnings_fail warnings_warn show_help show_man show_version
|
||||
state_class test_args state dry extensions ignore_exit rules state_manager
|
||||
normalize sources tapversion trap
|
||||
);
|
||||
__PACKAGE__->mk_methods(@ATTR);
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
Create a new C<App::Prove>. Optionally a hash ref of attribute
|
||||
initializers may be passed.
|
||||
|
||||
=cut
|
||||
|
||||
# new() implementation supplied by TAP::Object
|
||||
|
||||
sub _initialize {
|
||||
my $self = shift;
|
||||
my $args = shift || {};
|
||||
|
||||
my @is_array = qw(
|
||||
argv rc_opts includes modules state plugins rules sources
|
||||
);
|
||||
|
||||
# setup defaults:
|
||||
for my $key (@is_array) {
|
||||
$self->{$key} = [];
|
||||
}
|
||||
|
||||
for my $attr (@ATTR) {
|
||||
if ( exists $args->{$attr} ) {
|
||||
|
||||
# TODO: Some validation here
|
||||
$self->{$attr} = $args->{$attr};
|
||||
}
|
||||
}
|
||||
|
||||
$self->state_class('App::Prove::State');
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head3 C<state_class>
|
||||
|
||||
Getter/setter for the name of the class used for maintaining state. This
|
||||
class should either subclass from C<App::Prove::State> or provide an identical
|
||||
interface.
|
||||
|
||||
=head3 C<state_manager>
|
||||
|
||||
Getter/setter for the instance of the C<state_class>.
|
||||
|
||||
=cut
|
||||
|
||||
=head3 C<add_rc_file>
|
||||
|
||||
$prove->add_rc_file('myproj/.proverc');
|
||||
|
||||
Called before C<process_args> to prepend the contents of an rc file to
|
||||
the options.
|
||||
|
||||
=cut
|
||||
|
||||
sub add_rc_file {
|
||||
my ( $self, $rc_file ) = @_;
|
||||
|
||||
local *RC;
|
||||
open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
|
||||
while ( defined( my $line = <RC> ) ) {
|
||||
push @{ $self->{rc_opts} },
|
||||
grep { defined and not /^#/ }
|
||||
$line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
|
||||
}
|
||||
close RC;
|
||||
}
|
||||
|
||||
=head3 C<process_args>
|
||||
|
||||
$prove->process_args(@args);
|
||||
|
||||
Processes the command-line arguments. Attributes will be set
|
||||
appropriately. Any filenames may be found in the C<argv> attribute.
|
||||
|
||||
Dies on invalid arguments.
|
||||
|
||||
=cut
|
||||
|
||||
sub process_args {
|
||||
my $self = shift;
|
||||
|
||||
my @rc = RC_FILE;
|
||||
unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
|
||||
|
||||
# Preprocess meta-args.
|
||||
my @args;
|
||||
while ( defined( my $arg = shift ) ) {
|
||||
if ( $arg eq '--norc' ) {
|
||||
@rc = ();
|
||||
}
|
||||
elsif ( $arg eq '--rc' ) {
|
||||
defined( my $rc = shift )
|
||||
or croak "Missing argument to --rc";
|
||||
push @rc, $rc;
|
||||
}
|
||||
elsif ( $arg =~ m{^--rc=(.+)$} ) {
|
||||
push @rc, $1;
|
||||
}
|
||||
else {
|
||||
push @args, $arg;
|
||||
}
|
||||
}
|
||||
|
||||
# Everything after the arisdottle '::' gets passed as args to
|
||||
# test programs.
|
||||
if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
|
||||
my @test_args = splice @args, $stop_at;
|
||||
shift @test_args;
|
||||
$self->{test_args} = \@test_args;
|
||||
}
|
||||
|
||||
# Grab options from RC files
|
||||
$self->add_rc_file($_) for grep -f, @rc;
|
||||
unshift @args, @{ $self->{rc_opts} };
|
||||
|
||||
if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
|
||||
die "Long options should be written with two dashes: ",
|
||||
join( ', ', @bad ), "\n";
|
||||
}
|
||||
|
||||
# And finally...
|
||||
|
||||
{
|
||||
local @ARGV = @args;
|
||||
Getopt::Long::Configure(qw(no_ignore_case bundling pass_through));
|
||||
|
||||
# Don't add coderefs to GetOptions
|
||||
GetOptions(
|
||||
'v|verbose' => \$self->{verbose},
|
||||
'f|failures' => \$self->{failures},
|
||||
'o|comments' => \$self->{comments},
|
||||
'l|lib' => \$self->{lib},
|
||||
'b|blib' => \$self->{blib},
|
||||
's|shuffle' => \$self->{shuffle},
|
||||
'color!' => \$self->{color},
|
||||
'colour!' => \$self->{color},
|
||||
'count!' => \$self->{show_count},
|
||||
'c' => \$self->{color},
|
||||
'D|dry' => \$self->{dry},
|
||||
'ext=s@' => sub {
|
||||
my ( $opt, $val ) = @_;
|
||||
|
||||
# Workaround for Getopt::Long 2.25 handling of
|
||||
# multivalue options
|
||||
push @{ $self->{extensions} ||= [] }, $val;
|
||||
},
|
||||
'harness=s' => \$self->{harness},
|
||||
'ignore-exit' => \$self->{ignore_exit},
|
||||
'source=s@' => $self->{sources},
|
||||
'formatter=s' => \$self->{formatter},
|
||||
'r|recurse' => \$self->{recurse},
|
||||
'reverse' => \$self->{backwards},
|
||||
'p|parse' => \$self->{parse},
|
||||
'q|quiet' => \$self->{quiet},
|
||||
'Q|QUIET' => \$self->{really_quiet},
|
||||
'e|exec=s' => \$self->{exec},
|
||||
'm|merge' => \$self->{merge},
|
||||
'I=s@' => $self->{includes},
|
||||
'M=s@' => $self->{modules},
|
||||
'P=s@' => $self->{plugins},
|
||||
'state=s@' => $self->{state},
|
||||
'directives' => \$self->{directives},
|
||||
'h|help|?' => \$self->{show_help},
|
||||
'H|man' => \$self->{show_man},
|
||||
'V|version' => \$self->{show_version},
|
||||
'a|archive=s' => \$self->{archive},
|
||||
'j|jobs=i' => \$self->{jobs},
|
||||
'timer' => \$self->{timer},
|
||||
'T' => \$self->{taint_fail},
|
||||
't' => \$self->{taint_warn},
|
||||
'W' => \$self->{warnings_fail},
|
||||
'w' => \$self->{warnings_warn},
|
||||
'normalize' => \$self->{normalize},
|
||||
'rules=s@' => $self->{rules},
|
||||
'tapversion=s' => \$self->{tapversion},
|
||||
'trap' => \$self->{trap},
|
||||
) or croak('Unable to continue');
|
||||
|
||||
# Stash the remainder of argv for later
|
||||
$self->{argv} = [@ARGV];
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _first_pos {
|
||||
my $want = shift;
|
||||
for ( 0 .. $#_ ) {
|
||||
return $_ if $_[$_] eq $want;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _help {
|
||||
my ( $self, $verbosity ) = @_;
|
||||
|
||||
eval('use Pod::Usage 1.12 ()');
|
||||
if ( my $err = $@ ) {
|
||||
die 'Please install Pod::Usage for the --help option '
|
||||
. '(or try `perldoc prove`.)'
|
||||
. "\n ($@)";
|
||||
}
|
||||
|
||||
Pod::Usage::pod2usage( { -verbose => $verbosity } );
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _color_default {
|
||||
my $self = shift;
|
||||
|
||||
return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32;
|
||||
}
|
||||
|
||||
sub _get_args {
|
||||
my $self = shift;
|
||||
|
||||
my %args;
|
||||
|
||||
$args{trap} = 1 if $self->trap;
|
||||
|
||||
if ( defined $self->color ? $self->color : $self->_color_default ) {
|
||||
$args{color} = 1;
|
||||
}
|
||||
if ( !defined $self->show_count ) {
|
||||
$args{show_count} = 1;
|
||||
}
|
||||
else {
|
||||
$args{show_count} = $self->show_count;
|
||||
}
|
||||
|
||||
if ( $self->archive ) {
|
||||
$self->require_harness( archive => 'TAP::Harness::Archive' );
|
||||
$args{archive} = $self->archive;
|
||||
}
|
||||
|
||||
if ( my $jobs = $self->jobs ) {
|
||||
$args{jobs} = $jobs;
|
||||
}
|
||||
|
||||
if ( my $harness_opt = $self->harness ) {
|
||||
$self->require_harness( harness => $harness_opt );
|
||||
}
|
||||
|
||||
if ( my $formatter = $self->formatter ) {
|
||||
$args{formatter_class} = $formatter;
|
||||
}
|
||||
|
||||
for my $handler ( @{ $self->sources } ) {
|
||||
my ( $name, $config ) = $self->_parse_source($handler);
|
||||
$args{sources}->{$name} = $config;
|
||||
}
|
||||
|
||||
if ( $self->ignore_exit ) {
|
||||
$args{ignore_exit} = 1;
|
||||
}
|
||||
|
||||
if ( $self->taint_fail && $self->taint_warn ) {
|
||||
die '-t and -T are mutually exclusive';
|
||||
}
|
||||
|
||||
if ( $self->warnings_fail && $self->warnings_warn ) {
|
||||
die '-w and -W are mutually exclusive';
|
||||
}
|
||||
|
||||
for my $a (qw( lib switches )) {
|
||||
my $method = "_get_$a";
|
||||
my $val = $self->$method();
|
||||
$args{$a} = $val if defined $val;
|
||||
}
|
||||
|
||||
# Handle verbose, quiet, really_quiet flags
|
||||
my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
|
||||
|
||||
my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
|
||||
keys %verb_map;
|
||||
|
||||
die "Only one of verbose, quiet or really_quiet should be specified\n"
|
||||
if @verb_adj > 1;
|
||||
|
||||
$args{verbosity} = shift @verb_adj || 0;
|
||||
|
||||
for my $a (qw( merge failures comments timer directives normalize )) {
|
||||
$args{$a} = 1 if $self->$a();
|
||||
}
|
||||
|
||||
$args{errors} = 1 if $self->parse;
|
||||
|
||||
# defined but zero-length exec runs test files as binaries
|
||||
$args{exec} = [ split( /\s+/, $self->exec ) ]
|
||||
if ( defined( $self->exec ) );
|
||||
|
||||
$args{version} = $self->tapversion if defined( $self->tapversion );
|
||||
|
||||
if ( defined( my $test_args = $self->test_args ) ) {
|
||||
$args{test_args} = $test_args;
|
||||
}
|
||||
|
||||
if ( @{ $self->rules } ) {
|
||||
my @rules;
|
||||
for ( @{ $self->rules } ) {
|
||||
if (/^par=(.*)/) {
|
||||
push @rules, $1;
|
||||
}
|
||||
elsif (/^seq=(.*)/) {
|
||||
push @rules, { seq => $1 };
|
||||
}
|
||||
}
|
||||
$args{rules} = { par => [@rules] };
|
||||
}
|
||||
$args{harness_class} = $self->{harness_class} if $self->{harness_class};
|
||||
|
||||
return \%args;
|
||||
}
|
||||
|
||||
sub _find_module {
|
||||
my ( $self, $class, @search ) = @_;
|
||||
|
||||
croak "Bad module name $class"
|
||||
unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
|
||||
|
||||
for my $pfx (@search) {
|
||||
my $name = join( '::', $pfx, $class );
|
||||
eval "require $name";
|
||||
return $name unless $@;
|
||||
}
|
||||
|
||||
eval "require $class";
|
||||
return $class unless $@;
|
||||
return;
|
||||
}
|
||||
|
||||
sub _load_extension {
|
||||
my ( $self, $name, @search ) = @_;
|
||||
|
||||
my @args = ();
|
||||
if ( $name =~ /^(.*?)=(.*)/ ) {
|
||||
$name = $1;
|
||||
@args = split( /,/, $2 );
|
||||
}
|
||||
|
||||
if ( my $class = $self->_find_module( $name, @search ) ) {
|
||||
$class->import(@args);
|
||||
if ( $class->can('load') ) {
|
||||
$class->load( { app_prove => $self, args => [@args] } );
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "Can't load module $name";
|
||||
}
|
||||
}
|
||||
|
||||
sub _load_extensions {
|
||||
my ( $self, $ext, @search ) = @_;
|
||||
$self->_load_extension( $_, @search ) for @$ext;
|
||||
}
|
||||
|
||||
sub _parse_source {
|
||||
my ( $self, $handler ) = @_;
|
||||
|
||||
# Load any options.
|
||||
( my $opt_name = lc $handler ) =~ s/::/-/g;
|
||||
local @ARGV = @{ $self->{argv} };
|
||||
my %config;
|
||||
Getopt::Long::GetOptions(
|
||||
"$opt_name-option=s%" => sub {
|
||||
my ( $name, $k, $v ) = @_;
|
||||
if ( $v =~ /(?<!\\)=/ ) {
|
||||
|
||||
# It's a hash option.
|
||||
croak "Option $name must be consistently used as a hash"
|
||||
if exists $config{$k} && ref $config{$k} ne 'HASH';
|
||||
$config{$k} ||= {};
|
||||
my ( $hk, $hv ) = split /(?<!\\)=/, $v, 2;
|
||||
$config{$k}{$hk} = $hv;
|
||||
}
|
||||
else {
|
||||
$v =~ s/\\=/=/g;
|
||||
if ( exists $config{$k} ) {
|
||||
$config{$k} = [ $config{$k} ]
|
||||
unless ref $config{$k} eq 'ARRAY';
|
||||
push @{ $config{$k} } => $v;
|
||||
}
|
||||
else {
|
||||
$config{$k} = $v;
|
||||
}
|
||||
}
|
||||
}
|
||||
);
|
||||
$self->{argv} = \@ARGV;
|
||||
return ( $handler, \%config );
|
||||
}
|
||||
|
||||
=head3 C<run>
|
||||
|
||||
Perform whatever actions the command line args specified. The C<prove>
|
||||
command line tool consists of the following code:
|
||||
|
||||
use App::Prove;
|
||||
|
||||
my $app = App::Prove->new;
|
||||
$app->process_args(@ARGV);
|
||||
exit( $app->run ? 0 : 1 ); # if you need the exit code
|
||||
|
||||
=cut
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
|
||||
unless ( $self->state_manager ) {
|
||||
$self->state_manager(
|
||||
$self->state_class->new( { store => STATE_FILE } ) );
|
||||
}
|
||||
|
||||
if ( $self->show_help ) {
|
||||
$self->_help(1);
|
||||
}
|
||||
elsif ( $self->show_man ) {
|
||||
$self->_help(2);
|
||||
}
|
||||
elsif ( $self->show_version ) {
|
||||
$self->print_version;
|
||||
}
|
||||
elsif ( $self->dry ) {
|
||||
print "$_\n" for $self->_get_tests;
|
||||
}
|
||||
else {
|
||||
|
||||
$self->_load_extensions( $self->modules );
|
||||
$self->_load_extensions( $self->plugins, PLUGINS );
|
||||
|
||||
local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
|
||||
|
||||
return $self->_runtests( $self->_get_args, $self->_get_tests );
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _get_tests {
|
||||
my $self = shift;
|
||||
|
||||
my $state = $self->state_manager;
|
||||
my $ext = $self->extensions;
|
||||
$state->extensions($ext) if defined $ext;
|
||||
if ( defined( my $state_switch = $self->state ) ) {
|
||||
$state->apply_switch(@$state_switch);
|
||||
}
|
||||
|
||||
my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
|
||||
|
||||
$self->_shuffle(@tests) if $self->shuffle;
|
||||
@tests = reverse @tests if $self->backwards;
|
||||
|
||||
return @tests;
|
||||
}
|
||||
|
||||
sub _runtests {
|
||||
my ( $self, $args, @tests ) = @_;
|
||||
my $harness = TAP::Harness::Env->create($args);
|
||||
|
||||
my $state = $self->state_manager;
|
||||
|
||||
$harness->callback(
|
||||
after_test => sub {
|
||||
$state->observe_test(@_);
|
||||
}
|
||||
);
|
||||
|
||||
$harness->callback(
|
||||
after_runtests => sub {
|
||||
$state->commit(@_);
|
||||
}
|
||||
);
|
||||
|
||||
my $aggregator = $harness->runtests(@tests);
|
||||
|
||||
return !$aggregator->has_errors;
|
||||
}
|
||||
|
||||
sub _get_switches {
|
||||
my $self = shift;
|
||||
my @switches;
|
||||
|
||||
# notes that -T or -t must be at the front of the switches!
|
||||
if ( $self->taint_fail ) {
|
||||
push @switches, '-T';
|
||||
}
|
||||
elsif ( $self->taint_warn ) {
|
||||
push @switches, '-t';
|
||||
}
|
||||
if ( $self->warnings_fail ) {
|
||||
push @switches, '-W';
|
||||
}
|
||||
elsif ( $self->warnings_warn ) {
|
||||
push @switches, '-w';
|
||||
}
|
||||
|
||||
return @switches ? \@switches : ();
|
||||
}
|
||||
|
||||
sub _get_lib {
|
||||
my $self = shift;
|
||||
my @libs;
|
||||
if ( $self->lib ) {
|
||||
push @libs, 'lib';
|
||||
}
|
||||
if ( $self->blib ) {
|
||||
push @libs, 'blib/lib', 'blib/arch';
|
||||
}
|
||||
if ( @{ $self->includes } ) {
|
||||
push @libs, @{ $self->includes };
|
||||
}
|
||||
|
||||
#24926
|
||||
@libs = map { File::Spec->rel2abs($_) } @libs;
|
||||
|
||||
# Huh?
|
||||
return @libs ? \@libs : ();
|
||||
}
|
||||
|
||||
sub _shuffle {
|
||||
my $self = shift;
|
||||
|
||||
# Fisher-Yates shuffle
|
||||
my $i = @_;
|
||||
while ($i) {
|
||||
my $j = rand $i--;
|
||||
@_[ $i, $j ] = @_[ $j, $i ];
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
=head3 C<require_harness>
|
||||
|
||||
Load a harness replacement class.
|
||||
|
||||
$prove->require_harness($for => $class_name);
|
||||
|
||||
=cut
|
||||
|
||||
sub require_harness {
|
||||
my ( $self, $for, $class ) = @_;
|
||||
|
||||
my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
|
||||
|
||||
# Emulate Perl's -MModule=arg1,arg2 behaviour
|
||||
$class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
|
||||
|
||||
eval("use $class;");
|
||||
die "$class_name is required to use the --$for feature: $@" if $@;
|
||||
|
||||
$self->{harness_class} = $class_name;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
=head3 C<print_version>
|
||||
|
||||
Display the version numbers of the loaded L<TAP::Harness> and the
|
||||
current Perl.
|
||||
|
||||
=cut
|
||||
|
||||
sub print_version {
|
||||
my $self = shift;
|
||||
require TAP::Harness;
|
||||
printf(
|
||||
"TAP::Harness v%s and Perl v%vd\n",
|
||||
$TAP::Harness::VERSION, $^V
|
||||
);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim:ts=4:sw=4:et:sta
|
||||
|
||||
__END__
|
||||
|
||||
=head2 Attributes
|
||||
|
||||
After command line parsing the following attributes reflect the values
|
||||
of the corresponding command line switches. They may be altered before
|
||||
calling C<run>.
|
||||
|
||||
=over
|
||||
|
||||
=item C<archive>
|
||||
|
||||
=item C<argv>
|
||||
|
||||
=item C<backwards>
|
||||
|
||||
=item C<blib>
|
||||
|
||||
=item C<color>
|
||||
|
||||
=item C<directives>
|
||||
|
||||
=item C<dry>
|
||||
|
||||
=item C<exec>
|
||||
|
||||
=item C<extensions>
|
||||
|
||||
=item C<failures>
|
||||
|
||||
=item C<comments>
|
||||
|
||||
=item C<formatter>
|
||||
|
||||
=item C<harness>
|
||||
|
||||
=item C<ignore_exit>
|
||||
|
||||
=item C<includes>
|
||||
|
||||
=item C<jobs>
|
||||
|
||||
=item C<lib>
|
||||
|
||||
=item C<merge>
|
||||
|
||||
=item C<modules>
|
||||
|
||||
=item C<parse>
|
||||
|
||||
=item C<plugins>
|
||||
|
||||
=item C<quiet>
|
||||
|
||||
=item C<really_quiet>
|
||||
|
||||
=item C<recurse>
|
||||
|
||||
=item C<rules>
|
||||
|
||||
=item C<show_count>
|
||||
|
||||
=item C<show_help>
|
||||
|
||||
=item C<show_man>
|
||||
|
||||
=item C<show_version>
|
||||
|
||||
=item C<shuffle>
|
||||
|
||||
=item C<state>
|
||||
|
||||
=item C<state_class>
|
||||
|
||||
=item C<taint_fail>
|
||||
|
||||
=item C<taint_warn>
|
||||
|
||||
=item C<test_args>
|
||||
|
||||
=item C<timer>
|
||||
|
||||
=item C<verbose>
|
||||
|
||||
=item C<warnings_fail>
|
||||
|
||||
=item C<warnings_warn>
|
||||
|
||||
=item C<tapversion>
|
||||
|
||||
=item C<trap>
|
||||
|
||||
=back
|
||||
|
||||
=head1 PLUGINS
|
||||
|
||||
C<App::Prove> provides support for 3rd-party plugins. These are currently
|
||||
loaded at run-time, I<after> arguments have been parsed (so you can not
|
||||
change the way arguments are processed, sorry), typically with the
|
||||
C<< -PI<plugin> >> switch, eg:
|
||||
|
||||
prove -PMyPlugin
|
||||
|
||||
This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
|
||||
that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
|
||||
|
||||
You can pass an argument to your plugin by appending an C<=> after the plugin
|
||||
name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
|
||||
|
||||
prove -PMyPlugin=foo,bar,baz
|
||||
|
||||
These are passed in to your plugin's C<load()> class method (if it has one),
|
||||
along with a reference to the C<App::Prove> object that is invoking your plugin:
|
||||
|
||||
sub load {
|
||||
my ($class, $p) = @_;
|
||||
|
||||
my @args = @{ $p->{args} };
|
||||
# @args will contain ( 'foo', 'bar', 'baz' )
|
||||
$p->{app_prove}->do_something;
|
||||
...
|
||||
}
|
||||
|
||||
Note that the user's arguments are also passed to your plugin's C<import()>
|
||||
function as a list, eg:
|
||||
|
||||
sub import {
|
||||
my ($class, @args) = @_;
|
||||
# @args will contain ( 'foo', 'bar', 'baz' )
|
||||
...
|
||||
}
|
||||
|
||||
This is for backwards compatibility, and may be deprecated in the future.
|
||||
|
||||
=head2 Sample Plugin
|
||||
|
||||
Here's a sample plugin, for your reference:
|
||||
|
||||
package App::Prove::Plugin::Foo;
|
||||
|
||||
# Sample plugin, try running with:
|
||||
# prove -PFoo=bar -r -j3
|
||||
# prove -PFoo -Q
|
||||
# prove -PFoo=bar,My::Formatter
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub load {
|
||||
my ($class, $p) = @_;
|
||||
my @args = @{ $p->{args} };
|
||||
my $app = $p->{app_prove};
|
||||
|
||||
print "loading plugin: $class, args: ", join(', ', @args ), "\n";
|
||||
|
||||
# turn on verbosity
|
||||
$app->verbose( 1 );
|
||||
|
||||
# set the formatter?
|
||||
$app->formatter( $args[1] ) if @args > 1;
|
||||
|
||||
# print some of App::Prove's state:
|
||||
for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
|
||||
my $val = $app->$attr;
|
||||
$val = 'undef' unless defined( $val );
|
||||
print "$attr: $val\n";
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<prove>, L<TAP::Harness>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,548 @@
|
|||
package App::Prove::State;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use File::Find;
|
||||
use File::Spec;
|
||||
use Carp;
|
||||
|
||||
use App::Prove::State::Result;
|
||||
use TAP::Parser::YAMLish::Reader ();
|
||||
use TAP::Parser::YAMLish::Writer ();
|
||||
use base 'TAP::Base';
|
||||
|
||||
BEGIN {
|
||||
__PACKAGE__->mk_methods('result_class');
|
||||
}
|
||||
|
||||
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
|
||||
use constant NEED_GLOB => IS_WIN32;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove::State - State storage for the C<prove> command.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.35
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.35';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<prove> command supports a C<--state> option that instructs it to
|
||||
store persistent state across runs. This module implements that state
|
||||
and the operations that may be performed on it.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Re-run failed tests
|
||||
$ prove --state=failed,save -rbv
|
||||
|
||||
=cut
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
Accepts a hashref with the following key/value pairs:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * C<store>
|
||||
|
||||
The filename of the data store holding the data that App::Prove::State reads.
|
||||
|
||||
=item * C<extensions> (optional)
|
||||
|
||||
The test name extensions. Defaults to C<.t>.
|
||||
|
||||
=item * C<result_class> (optional)
|
||||
|
||||
The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
# override TAP::Base::new:
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %args = %{ shift || {} };
|
||||
|
||||
my $self = bless {
|
||||
select => [],
|
||||
seq => 1,
|
||||
store => delete $args{store},
|
||||
extensions => ( delete $args{extensions} || ['.t'] ),
|
||||
result_class =>
|
||||
( delete $args{result_class} || 'App::Prove::State::Result' ),
|
||||
}, $class;
|
||||
|
||||
$self->{_} = $self->result_class->new(
|
||||
{ tests => {},
|
||||
generation => 1,
|
||||
}
|
||||
);
|
||||
my $store = $self->{store};
|
||||
$self->load($store)
|
||||
if defined $store && -f $store;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 C<result_class>
|
||||
|
||||
Getter/setter for the name of the class used for tracking test results. This
|
||||
class should either subclass from C<App::Prove::State::Result> or provide an
|
||||
identical interface.
|
||||
|
||||
=cut
|
||||
|
||||
=head2 C<extensions>
|
||||
|
||||
Get or set the list of extensions that files must have in order to be
|
||||
considered tests. Defaults to ['.t'].
|
||||
|
||||
=cut
|
||||
|
||||
sub extensions {
|
||||
my $self = shift;
|
||||
$self->{extensions} = shift if @_;
|
||||
return $self->{extensions};
|
||||
}
|
||||
|
||||
=head2 C<results>
|
||||
|
||||
Get the results of the last test run. Returns a C<result_class()> instance.
|
||||
|
||||
=cut
|
||||
|
||||
sub results {
|
||||
my $self = shift;
|
||||
$self->{_} || $self->result_class->new;
|
||||
}
|
||||
|
||||
=head2 C<commit>
|
||||
|
||||
Save the test results. Should be called after all tests have run.
|
||||
|
||||
=cut
|
||||
|
||||
sub commit {
|
||||
my $self = shift;
|
||||
if ( $self->{should_save} ) {
|
||||
$self->save;
|
||||
}
|
||||
}
|
||||
|
||||
=head2 Instance Methods
|
||||
|
||||
=head3 C<apply_switch>
|
||||
|
||||
$self->apply_switch('failed,save');
|
||||
|
||||
Apply a list of switch options to the state, updating the internal
|
||||
object state as a result. Nothing is returned.
|
||||
|
||||
Diagnostics:
|
||||
- "Illegal state option: %s"
|
||||
|
||||
=over
|
||||
|
||||
=item C<last>
|
||||
|
||||
Run in the same order as last time
|
||||
|
||||
=item C<failed>
|
||||
|
||||
Run only the failed tests from last time
|
||||
|
||||
=item C<passed>
|
||||
|
||||
Run only the passed tests from last time
|
||||
|
||||
=item C<all>
|
||||
|
||||
Run all tests in normal order
|
||||
|
||||
=item C<hot>
|
||||
|
||||
Run the tests that most recently failed first
|
||||
|
||||
=item C<todo>
|
||||
|
||||
Run the tests ordered by number of todos.
|
||||
|
||||
=item C<slow>
|
||||
|
||||
Run the tests in slowest to fastest order.
|
||||
|
||||
=item C<fast>
|
||||
|
||||
Run test tests in fastest to slowest order.
|
||||
|
||||
=item C<new>
|
||||
|
||||
Run the tests in newest to oldest order.
|
||||
|
||||
=item C<old>
|
||||
|
||||
Run the tests in oldest to newest order.
|
||||
|
||||
=item C<save>
|
||||
|
||||
Save the state on exit.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub apply_switch {
|
||||
my $self = shift;
|
||||
my @opts = @_;
|
||||
|
||||
my $last_gen = $self->results->generation - 1;
|
||||
my $last_run_time = $self->results->last_run_time;
|
||||
my $now = $self->get_time;
|
||||
|
||||
my @switches = map { split /,/ } @opts;
|
||||
|
||||
my %handler = (
|
||||
last => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->generation >= $last_gen },
|
||||
order => sub { $_->sequence }
|
||||
);
|
||||
},
|
||||
failed => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->result != 0 },
|
||||
order => sub { -$_->result }
|
||||
);
|
||||
},
|
||||
passed => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->result == 0 }
|
||||
);
|
||||
},
|
||||
all => sub {
|
||||
$self->_select( limit => shift );
|
||||
},
|
||||
todo => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->num_todo != 0 },
|
||||
order => sub { -$_->num_todo; }
|
||||
);
|
||||
},
|
||||
hot => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { defined $_->last_fail_time },
|
||||
order => sub { $now - $_->last_fail_time }
|
||||
);
|
||||
},
|
||||
slow => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { -$_->elapsed }
|
||||
);
|
||||
},
|
||||
fast => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { $_->elapsed }
|
||||
);
|
||||
},
|
||||
new => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { -$_->mtime }
|
||||
);
|
||||
},
|
||||
old => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
order => sub { $_->mtime }
|
||||
);
|
||||
},
|
||||
fresh => sub {
|
||||
$self->_select(
|
||||
limit => shift,
|
||||
where => sub { $_->mtime >= $last_run_time }
|
||||
);
|
||||
},
|
||||
save => sub {
|
||||
$self->{should_save}++;
|
||||
},
|
||||
adrian => sub {
|
||||
unshift @switches, qw( hot all save );
|
||||
},
|
||||
);
|
||||
|
||||
while ( defined( my $ele = shift @switches ) ) {
|
||||
my ( $opt, $arg )
|
||||
= ( $ele =~ /^([^:]+):(.*)/ )
|
||||
? ( $1, $2 )
|
||||
: ( $ele, undef );
|
||||
my $code = $handler{$opt}
|
||||
|| croak "Illegal state option: $opt";
|
||||
$code->($arg);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _select {
|
||||
my ( $self, %spec ) = @_;
|
||||
push @{ $self->{select} }, \%spec;
|
||||
}
|
||||
|
||||
=head3 C<get_tests>
|
||||
|
||||
Given a list of args get the names of tests that should run
|
||||
|
||||
=cut
|
||||
|
||||
sub get_tests {
|
||||
my $self = shift;
|
||||
my $recurse = shift;
|
||||
my @argv = @_;
|
||||
my %seen;
|
||||
|
||||
my @selected = $self->_query;
|
||||
|
||||
unless ( @argv || @{ $self->{select} } ) {
|
||||
@argv = $recurse ? '.' : 't';
|
||||
croak qq{No tests named and '@argv' directory not found}
|
||||
unless -d $argv[0];
|
||||
}
|
||||
|
||||
push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
|
||||
return grep { !$seen{$_}++ } @selected;
|
||||
}
|
||||
|
||||
sub _query {
|
||||
my $self = shift;
|
||||
if ( my @sel = @{ $self->{select} } ) {
|
||||
warn "No saved state, selection will be empty\n"
|
||||
unless $self->results->num_tests;
|
||||
return map { $self->_query_clause($_) } @sel;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _query_clause {
|
||||
my ( $self, $clause ) = @_;
|
||||
my @got;
|
||||
my $results = $self->results;
|
||||
my $where = $clause->{where} || sub {1};
|
||||
|
||||
# Select
|
||||
for my $name ( $results->test_names ) {
|
||||
next unless -f $name;
|
||||
local $_ = $results->test($name);
|
||||
push @got, $name if $where->();
|
||||
}
|
||||
|
||||
# Sort
|
||||
if ( my $order = $clause->{order} ) {
|
||||
@got = map { $_->[0] }
|
||||
sort {
|
||||
( defined $b->[1] <=> defined $a->[1] )
|
||||
|| ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
|
||||
} map {
|
||||
[ $_,
|
||||
do { local $_ = $results->test($_); $order->() }
|
||||
]
|
||||
} @got;
|
||||
}
|
||||
|
||||
if ( my $limit = $clause->{limit} ) {
|
||||
@got = splice @got, 0, $limit if @got > $limit;
|
||||
}
|
||||
|
||||
return @got;
|
||||
}
|
||||
|
||||
sub _get_raw_tests {
|
||||
my $self = shift;
|
||||
my $recurse = shift;
|
||||
my @argv = @_;
|
||||
my @tests;
|
||||
|
||||
# Do globbing on Win32.
|
||||
if (NEED_GLOB) {
|
||||
eval "use File::Glob::Windows"; # [49732]
|
||||
@argv = map { glob "$_" } @argv;
|
||||
}
|
||||
my $extensions = $self->{extensions};
|
||||
|
||||
for my $arg (@argv) {
|
||||
if ( '-' eq $arg ) {
|
||||
push @argv => <STDIN>;
|
||||
chomp(@argv);
|
||||
next;
|
||||
}
|
||||
|
||||
push @tests,
|
||||
sort -d $arg
|
||||
? $recurse
|
||||
? $self->_expand_dir_recursive( $arg, $extensions )
|
||||
: map { glob( File::Spec->catfile( $arg, "*$_" ) ) }
|
||||
@{$extensions}
|
||||
: $arg;
|
||||
}
|
||||
return @tests;
|
||||
}
|
||||
|
||||
sub _expand_dir_recursive {
|
||||
my ( $self, $dir, $extensions ) = @_;
|
||||
|
||||
my @tests;
|
||||
my $ext_string = join( '|', map {quotemeta} @{$extensions} );
|
||||
|
||||
find(
|
||||
{ follow => 1, #21938
|
||||
follow_skip => 2,
|
||||
wanted => sub {
|
||||
-f
|
||||
&& /(?:$ext_string)$/
|
||||
&& push @tests => $File::Find::name;
|
||||
}
|
||||
},
|
||||
$dir
|
||||
);
|
||||
return @tests;
|
||||
}
|
||||
|
||||
=head3 C<observe_test>
|
||||
|
||||
Store the results of a test.
|
||||
|
||||
=cut
|
||||
|
||||
# Store:
|
||||
# last fail time
|
||||
# last pass time
|
||||
# last run time
|
||||
# most recent result
|
||||
# most recent todos
|
||||
# total failures
|
||||
# total passes
|
||||
# state generation
|
||||
# parser
|
||||
|
||||
sub observe_test {
|
||||
|
||||
my ( $self, $test_info, $parser ) = @_;
|
||||
my $name = $test_info->[0];
|
||||
my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
|
||||
my $todo = scalar( $parser->todo );
|
||||
my $start_time = $parser->start_time;
|
||||
my $end_time = $parser->end_time,
|
||||
|
||||
my $test = $self->results->test($name);
|
||||
|
||||
$test->sequence( $self->{seq}++ );
|
||||
$test->generation( $self->results->generation );
|
||||
|
||||
$test->run_time($end_time);
|
||||
$test->result($fail);
|
||||
$test->num_todo($todo);
|
||||
$test->elapsed( $end_time - $start_time );
|
||||
|
||||
$test->parser($parser);
|
||||
|
||||
if ($fail) {
|
||||
$test->total_failures( $test->total_failures + 1 );
|
||||
$test->last_fail_time($end_time);
|
||||
}
|
||||
else {
|
||||
$test->total_passes( $test->total_passes + 1 );
|
||||
$test->last_pass_time($end_time);
|
||||
}
|
||||
}
|
||||
|
||||
=head3 C<save>
|
||||
|
||||
Write the state to a file.
|
||||
|
||||
=cut
|
||||
|
||||
sub save {
|
||||
my ($self) = @_;
|
||||
|
||||
my $store = $self->{store} or return;
|
||||
$self->results->last_run_time( $self->get_time );
|
||||
|
||||
my $writer = TAP::Parser::YAMLish::Writer->new;
|
||||
local *FH;
|
||||
open FH, ">$store" or croak "Can't write $store ($!)";
|
||||
$writer->write( $self->results->raw, \*FH );
|
||||
close FH;
|
||||
}
|
||||
|
||||
=head3 C<load>
|
||||
|
||||
Load the state from a file
|
||||
|
||||
=cut
|
||||
|
||||
sub load {
|
||||
my ( $self, $name ) = @_;
|
||||
my $reader = TAP::Parser::YAMLish::Reader->new;
|
||||
local *FH;
|
||||
open FH, "<$name" or croak "Can't read $name ($!)";
|
||||
|
||||
# XXX this is temporary
|
||||
$self->{_} = $self->result_class->new(
|
||||
$reader->read(
|
||||
sub {
|
||||
my $line = <FH>;
|
||||
defined $line && chomp $line;
|
||||
return $line;
|
||||
}
|
||||
)
|
||||
);
|
||||
|
||||
# $writer->write( $self->{tests} || {}, \*FH );
|
||||
close FH;
|
||||
$self->_regen_seq;
|
||||
$self->_prune_and_stamp;
|
||||
$self->results->generation( $self->results->generation + 1 );
|
||||
}
|
||||
|
||||
sub _prune_and_stamp {
|
||||
my $self = shift;
|
||||
|
||||
my $results = $self->results;
|
||||
my @tests = $self->results->tests;
|
||||
for my $test (@tests) {
|
||||
my $name = $test->name;
|
||||
if ( my @stat = stat $name ) {
|
||||
$test->mtime( $stat[9] );
|
||||
}
|
||||
else {
|
||||
$results->remove($name);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _regen_seq {
|
||||
my $self = shift;
|
||||
for my $test ( $self->results->tests ) {
|
||||
$self->{seq} = $test->sequence + 1
|
||||
if defined $test->sequence && $test->sequence >= $self->{seq};
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,233 @@
|
|||
package App::Prove::State::Result;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp 'croak';
|
||||
|
||||
use App::Prove::State::Result::Test;
|
||||
|
||||
use constant STATE_VERSION => 1;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove::State::Result - Individual test suite results.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.35
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.35';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<prove> command supports a C<--state> option that instructs it to
|
||||
store persistent state across runs. This module encapsulates the results for a
|
||||
single test suite run.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Re-run failed tests
|
||||
$ prove --state=failed,save -rbv
|
||||
|
||||
=cut
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
my $result = App::Prove::State::Result->new({
|
||||
generation => $generation,
|
||||
tests => \%tests,
|
||||
});
|
||||
|
||||
Returns a new C<App::Prove::State::Result> instance.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $arg_for ) = @_;
|
||||
$arg_for ||= {};
|
||||
my %instance_data = %$arg_for; # shallow copy
|
||||
$instance_data{version} = $class->state_version;
|
||||
my $tests = delete $instance_data{tests} || {};
|
||||
my $self = bless \%instance_data => $class;
|
||||
$self->_initialize($tests);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ( $self, $tests ) = @_;
|
||||
my %tests;
|
||||
while ( my ( $name, $test ) = each %$tests ) {
|
||||
$tests{$name} = $self->test_class->new(
|
||||
{ %$test,
|
||||
name => $name
|
||||
}
|
||||
);
|
||||
}
|
||||
$self->tests( \%tests );
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head2 C<state_version>
|
||||
|
||||
Returns the current version of state storage.
|
||||
|
||||
=cut
|
||||
|
||||
sub state_version {STATE_VERSION}
|
||||
|
||||
=head2 C<test_class>
|
||||
|
||||
Returns the name of the class used for tracking individual tests. This class
|
||||
should either subclass from C<App::Prove::State::Result::Test> or provide an
|
||||
identical interface.
|
||||
|
||||
=cut
|
||||
|
||||
sub test_class {
|
||||
return 'App::Prove::State::Result::Test';
|
||||
}
|
||||
|
||||
my %methods = (
|
||||
generation => { method => 'generation', default => 0 },
|
||||
last_run_time => { method => 'last_run_time', default => undef },
|
||||
);
|
||||
|
||||
while ( my ( $key, $description ) = each %methods ) {
|
||||
my $default = $description->{default};
|
||||
no strict 'refs';
|
||||
*{ $description->{method} } = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{$key} = shift;
|
||||
return $self;
|
||||
}
|
||||
return $self->{$key} || $default;
|
||||
};
|
||||
}
|
||||
|
||||
=head3 C<generation>
|
||||
|
||||
Getter/setter for the "generation" of the test suite run. The first
|
||||
generation is 1 (one) and subsequent generations are 2, 3, etc.
|
||||
|
||||
=head3 C<last_run_time>
|
||||
|
||||
Getter/setter for the time of the test suite run.
|
||||
|
||||
=head3 C<tests>
|
||||
|
||||
Returns the tests for a given generation. This is a hashref or a hash,
|
||||
depending on context called. The keys to the hash are the individual
|
||||
test names and the value is a hashref with various interesting values.
|
||||
Each k/v pair might resemble something like this:
|
||||
|
||||
't/foo.t' => {
|
||||
elapsed => '0.0428488254547119',
|
||||
gen => '7',
|
||||
last_pass_time => '1219328376.07815',
|
||||
last_result => '0',
|
||||
last_run_time => '1219328376.07815',
|
||||
last_todo => '0',
|
||||
mtime => '1191708862',
|
||||
seq => '192',
|
||||
total_passes => '6',
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub tests {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{tests} = shift;
|
||||
return $self;
|
||||
}
|
||||
my %tests = %{ $self->{tests} };
|
||||
my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
|
||||
return wantarray ? @tests : \@tests;
|
||||
}
|
||||
|
||||
=head3 C<test>
|
||||
|
||||
my $test = $result->test('t/customer/create.t');
|
||||
|
||||
Returns an individual C<App::Prove::State::Result::Test> instance for the
|
||||
given test name (usually the filename). Will return a new
|
||||
C<App::Prove::State::Result::Test> instance if the name is not found.
|
||||
|
||||
=cut
|
||||
|
||||
sub test {
|
||||
my ( $self, $name ) = @_;
|
||||
croak("test() requires a test name") unless defined $name;
|
||||
|
||||
my $tests = $self->{tests} ||= {};
|
||||
if ( my $test = $tests->{$name} ) {
|
||||
return $test;
|
||||
}
|
||||
else {
|
||||
my $test = $self->test_class->new( { name => $name } );
|
||||
$self->{tests}->{$name} = $test;
|
||||
return $test;
|
||||
}
|
||||
}
|
||||
|
||||
=head3 C<test_names>
|
||||
|
||||
Returns an list of test names, sorted by run order.
|
||||
|
||||
=cut
|
||||
|
||||
sub test_names {
|
||||
my $self = shift;
|
||||
return map { $_->name } $self->tests;
|
||||
}
|
||||
|
||||
=head3 C<remove>
|
||||
|
||||
$result->remove($test_name); # remove the test
|
||||
my $test = $result->test($test_name); # fatal error
|
||||
|
||||
Removes a given test from results. This is a no-op if the test name is not
|
||||
found.
|
||||
|
||||
=cut
|
||||
|
||||
sub remove {
|
||||
my ( $self, $name ) = @_;
|
||||
delete $self->{tests}->{$name};
|
||||
return $self;
|
||||
}
|
||||
|
||||
=head3 C<num_tests>
|
||||
|
||||
Returns the number of tests for a given test suite result.
|
||||
|
||||
=cut
|
||||
|
||||
sub num_tests { keys %{ shift->{tests} } }
|
||||
|
||||
=head3 C<raw>
|
||||
|
||||
Returns a hashref of raw results, suitable for serialization by YAML.
|
||||
|
||||
=cut
|
||||
|
||||
sub raw {
|
||||
my $self = shift;
|
||||
my %raw = %$self;
|
||||
|
||||
my %tests;
|
||||
for my $test ( $self->tests ) {
|
||||
$tests{ $test->name } = $test->raw;
|
||||
}
|
||||
$raw{tests} = \%tests;
|
||||
return \%raw;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,152 @@
|
|||
package App::Prove::State::Result::Test;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
App::Prove::State::Result::Test - Individual test results.
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.35
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.35';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<prove> command supports a C<--state> option that instructs it to
|
||||
store persistent state across runs. This module encapsulates the results for a
|
||||
single test.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Re-run failed tests
|
||||
$ prove --state=failed,save -rbv
|
||||
|
||||
=cut
|
||||
|
||||
my %methods = (
|
||||
name => { method => 'name' },
|
||||
elapsed => { method => 'elapsed', default => 0 },
|
||||
gen => { method => 'generation', default => 1 },
|
||||
last_pass_time => { method => 'last_pass_time', default => undef },
|
||||
last_fail_time => { method => 'last_fail_time', default => undef },
|
||||
last_result => { method => 'result', default => 0 },
|
||||
last_run_time => { method => 'run_time', default => undef },
|
||||
last_todo => { method => 'num_todo', default => 0 },
|
||||
mtime => { method => 'mtime', default => undef },
|
||||
seq => { method => 'sequence', default => 1 },
|
||||
total_passes => { method => 'total_passes', default => 0 },
|
||||
total_failures => { method => 'total_failures', default => 0 },
|
||||
parser => { method => 'parser' },
|
||||
);
|
||||
|
||||
while ( my ( $key, $description ) = each %methods ) {
|
||||
my $default = $description->{default};
|
||||
no strict 'refs';
|
||||
*{ $description->{method} } = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{$key} = shift;
|
||||
return $self;
|
||||
}
|
||||
return $self->{$key} || $default;
|
||||
};
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 Class Methods
|
||||
|
||||
=head3 C<new>
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ( $class, $arg_for ) = @_;
|
||||
$arg_for ||= {};
|
||||
bless $arg_for => $class;
|
||||
}
|
||||
|
||||
=head2 Instance Methods
|
||||
|
||||
=head3 C<name>
|
||||
|
||||
The name of the test. Usually a filename.
|
||||
|
||||
=head3 C<elapsed>
|
||||
|
||||
The total elapsed times the test took to run, in seconds from the epoch..
|
||||
|
||||
=head3 C<generation>
|
||||
|
||||
The number for the "generation" of the test run. The first generation is 1
|
||||
(one) and subsequent generations are 2, 3, etc.
|
||||
|
||||
=head3 C<last_pass_time>
|
||||
|
||||
The last time the test program passed, in seconds from the epoch.
|
||||
|
||||
Returns C<undef> if the program has never passed.
|
||||
|
||||
=head3 C<last_fail_time>
|
||||
|
||||
The last time the test suite failed, in seconds from the epoch.
|
||||
|
||||
Returns C<undef> if the program has never failed.
|
||||
|
||||
=head3 C<mtime>
|
||||
|
||||
Returns the mtime of the test, in seconds from the epoch.
|
||||
|
||||
=head3 C<raw>
|
||||
|
||||
Returns a hashref of raw test data, suitable for serialization by YAML.
|
||||
|
||||
=head3 C<result>
|
||||
|
||||
Currently, whether or not the test suite passed with no 'problems' (such as
|
||||
TODO passed).
|
||||
|
||||
=head3 C<run_time>
|
||||
|
||||
The total time it took for the test to run, in seconds. If C<Time::HiRes> is
|
||||
available, it will have finer granularity.
|
||||
|
||||
=head3 C<num_todo>
|
||||
|
||||
The number of tests with TODO directives.
|
||||
|
||||
=head3 C<sequence>
|
||||
|
||||
The order in which this test was run for the given test suite result.
|
||||
|
||||
=head3 C<total_passes>
|
||||
|
||||
The number of times the test has passed.
|
||||
|
||||
=head3 C<total_failures>
|
||||
|
||||
The number of times the test has failed.
|
||||
|
||||
=head3 C<parser>
|
||||
|
||||
The underlying parser object. This is useful if you need the full
|
||||
information for the test program.
|
||||
|
||||
=cut
|
||||
|
||||
sub raw {
|
||||
my $self = shift;
|
||||
my %raw = %$self;
|
||||
|
||||
# this is backwards-compatibility hack and is not guaranteed.
|
||||
delete $raw{name};
|
||||
delete $raw{parser};
|
||||
return \%raw;
|
||||
}
|
||||
|
||||
1;
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,110 @@
|
|||
package Archive::Tar::Constant;
|
||||
|
||||
BEGIN {
|
||||
require Exporter;
|
||||
|
||||
$VERSION = '2.04';
|
||||
@ISA = qw[Exporter];
|
||||
|
||||
require Time::Local if $^O eq "MacOS";
|
||||
}
|
||||
|
||||
@EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ );
|
||||
|
||||
use constant FILE => 0;
|
||||
use constant HARDLINK => 1;
|
||||
use constant SYMLINK => 2;
|
||||
use constant CHARDEV => 3;
|
||||
use constant BLOCKDEV => 4;
|
||||
use constant DIR => 5;
|
||||
use constant FIFO => 6;
|
||||
use constant SOCKET => 8;
|
||||
use constant UNKNOWN => 9;
|
||||
use constant LONGLINK => 'L';
|
||||
use constant LABEL => 'V';
|
||||
|
||||
use constant BUFFER => 4096;
|
||||
use constant HEAD => 512;
|
||||
use constant BLOCK => 512;
|
||||
|
||||
use constant COMPRESS_GZIP => 9;
|
||||
use constant COMPRESS_BZIP => 'bzip2';
|
||||
|
||||
use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
|
||||
use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
|
||||
use constant TAR_END => "\0" x BLOCK;
|
||||
|
||||
use constant READ_ONLY => sub { shift() ? 'rb' : 'r' };
|
||||
use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' };
|
||||
use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 };
|
||||
|
||||
# Pointless assignment to make -w shut up
|
||||
my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
|
||||
my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
|
||||
use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
|
||||
use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
|
||||
use constant UID => $>;
|
||||
use constant GID => (split ' ', $) )[0];
|
||||
|
||||
use constant MODE => do { 0666 & (0777 & ~umask) };
|
||||
use constant STRIP_MODE => sub { shift() & 0777 };
|
||||
use constant CHECK_SUM => " ";
|
||||
|
||||
use constant UNPACK => 'A100 A8 A8 A8 a12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
|
||||
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
|
||||
use constant NAME_LENGTH => 100;
|
||||
use constant PREFIX_LENGTH => 155;
|
||||
|
||||
use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
|
||||
use constant MAGIC => "ustar";
|
||||
use constant TAR_VERSION => "00";
|
||||
use constant LONGLINK_NAME => '././@LongLink';
|
||||
use constant PAX_HEADER => 'pax_global_header';
|
||||
|
||||
### allow ZLIB to be turned off using ENV: DEBUG only
|
||||
use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
|
||||
eval { require IO::Zlib };
|
||||
$ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
|
||||
};
|
||||
|
||||
### allow BZIP to be turned off using ENV: DEBUG only
|
||||
use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
|
||||
eval { require IO::Uncompress::Bunzip2;
|
||||
require IO::Compress::Bzip2; };
|
||||
$ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
|
||||
};
|
||||
|
||||
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
|
||||
use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
|
||||
|
||||
use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
|
||||
use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
|
||||
use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
|
||||
use constant ON_VMS => $^O eq 'VMS';
|
||||
|
||||
sub _list_consts {
|
||||
my $class = shift;
|
||||
my $pkg = shift;
|
||||
return unless defined $pkg; # some joker might use '0' as a pkg...
|
||||
|
||||
my @rv;
|
||||
{ no strict 'refs';
|
||||
my $stash = $pkg . '::';
|
||||
|
||||
for my $name (sort keys %$stash ) {
|
||||
|
||||
### is it a subentry?
|
||||
my $sub = $pkg->can( $name );
|
||||
next unless defined $sub;
|
||||
|
||||
next unless defined prototype($sub) and
|
||||
not length prototype($sub);
|
||||
|
||||
push @rv, $name;
|
||||
}
|
||||
}
|
||||
|
||||
return sort @rv;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,715 @@
|
|||
package Archive::Tar::File;
|
||||
use strict;
|
||||
|
||||
use Carp ();
|
||||
use IO::File;
|
||||
use File::Spec::Unix ();
|
||||
use File::Spec ();
|
||||
use File::Basename ();
|
||||
|
||||
### avoid circular use, so only require;
|
||||
require Archive::Tar;
|
||||
use Archive::Tar::Constant;
|
||||
|
||||
use vars qw[@ISA $VERSION];
|
||||
#@ISA = qw[Archive::Tar];
|
||||
$VERSION = '2.04';
|
||||
|
||||
### set value to 1 to oct() it during the unpack ###
|
||||
|
||||
my $tmpl = [
|
||||
name => 0, # string A100
|
||||
mode => 1, # octal A8
|
||||
uid => 1, # octal A8
|
||||
gid => 1, # octal A8
|
||||
size => 0, # octal # cdrake - not *always* octal.. A12
|
||||
mtime => 1, # octal A12
|
||||
chksum => 1, # octal A8
|
||||
type => 0, # character A1
|
||||
linkname => 0, # string A100
|
||||
magic => 0, # string A6
|
||||
version => 0, # 2 bytes A2
|
||||
uname => 0, # string A32
|
||||
gname => 0, # string A32
|
||||
devmajor => 1, # octal A8
|
||||
devminor => 1, # octal A8
|
||||
prefix => 0, # A155 x 12
|
||||
|
||||
### end UNPACK items ###
|
||||
raw => 0, # the raw data chunk
|
||||
data => 0, # the data associated with the file --
|
||||
# This might be very memory intensive
|
||||
];
|
||||
|
||||
### install get/set accessors for this object.
|
||||
for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
|
||||
my $key = $tmpl->[$i];
|
||||
no strict 'refs';
|
||||
*{__PACKAGE__."::$key"} = sub {
|
||||
my $self = shift;
|
||||
$self->{$key} = $_[0] if @_;
|
||||
|
||||
### just in case the key is not there or undef or something ###
|
||||
{ local $^W = 0;
|
||||
return $self->{$key};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my @items = $tar->get_files;
|
||||
|
||||
print $_->name, ' ', $_->size, "\n" for @items;
|
||||
|
||||
print $object->get_content;
|
||||
$object->replace_content('new content');
|
||||
|
||||
$object->rename( 'new/full/path/to/file.c' );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Archive::Tar::Files provides a neat little object layer for in-memory
|
||||
extracted files. It's mostly used internally in Archive::Tar to tidy
|
||||
up the code, but there's no reason users shouldn't use this API as
|
||||
well.
|
||||
|
||||
=head2 Accessors
|
||||
|
||||
A lot of the methods in this package are accessors to the various
|
||||
fields in the tar header:
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
The file's name
|
||||
|
||||
=item mode
|
||||
|
||||
The file's mode
|
||||
|
||||
=item uid
|
||||
|
||||
The user id owning the file
|
||||
|
||||
=item gid
|
||||
|
||||
The group id owning the file
|
||||
|
||||
=item size
|
||||
|
||||
File size in bytes
|
||||
|
||||
=item mtime
|
||||
|
||||
Modification time. Adjusted to mac-time on MacOS if required
|
||||
|
||||
=item chksum
|
||||
|
||||
Checksum field for the tar header
|
||||
|
||||
=item type
|
||||
|
||||
File type -- numeric, but comparable to exported constants -- see
|
||||
Archive::Tar's documentation
|
||||
|
||||
=item linkname
|
||||
|
||||
If the file is a symlink, the file it's pointing to
|
||||
|
||||
=item magic
|
||||
|
||||
Tar magic string -- not useful for most users
|
||||
|
||||
=item version
|
||||
|
||||
Tar version string -- not useful for most users
|
||||
|
||||
=item uname
|
||||
|
||||
The user name that owns the file
|
||||
|
||||
=item gname
|
||||
|
||||
The group name that owns the file
|
||||
|
||||
=item devmajor
|
||||
|
||||
Device major number in case of a special file
|
||||
|
||||
=item devminor
|
||||
|
||||
Device minor number in case of a special file
|
||||
|
||||
=item prefix
|
||||
|
||||
Any directory to prefix to the extraction path, if any
|
||||
|
||||
=item raw
|
||||
|
||||
Raw tar header -- not useful for most users
|
||||
|
||||
=back
|
||||
|
||||
=head1 Methods
|
||||
|
||||
=head2 Archive::Tar::File->new( file => $path )
|
||||
|
||||
Returns a new Archive::Tar::File object from an existing file.
|
||||
|
||||
Returns undef on failure.
|
||||
|
||||
=head2 Archive::Tar::File->new( data => $path, $data, $opt )
|
||||
|
||||
Returns a new Archive::Tar::File object from data.
|
||||
|
||||
C<$path> defines the file name (which need not exist), C<$data> the
|
||||
file contents, and C<$opt> is a reference to a hash of attributes
|
||||
which may be used to override the default attributes (fields in the
|
||||
tar header), which are described above in the Accessors section.
|
||||
|
||||
Returns undef on failure.
|
||||
|
||||
=head2 Archive::Tar::File->new( chunk => $chunk )
|
||||
|
||||
Returns a new Archive::Tar::File object from a raw 512-byte tar
|
||||
archive chunk.
|
||||
|
||||
Returns undef on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $what = shift;
|
||||
|
||||
my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
|
||||
($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
|
||||
($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
|
||||
undef;
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
### copies the data, creates a clone ###
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
return bless { %$self }, ref $self;
|
||||
}
|
||||
|
||||
sub _new_from_chunk {
|
||||
my $class = shift;
|
||||
my $chunk = shift or return; # 512 bytes of tar header
|
||||
my %hash = @_;
|
||||
|
||||
### filter any arguments on defined-ness of values.
|
||||
### this allows overriding from what the tar-header is saying
|
||||
### about this tar-entry. Particularly useful for @LongLink files
|
||||
my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
|
||||
|
||||
### makes it start at 0 actually... :) ###
|
||||
my $i = -1;
|
||||
my %entry = map {
|
||||
my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake
|
||||
($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake
|
||||
$s=> $v ? oct $_ : $_ # cdrake
|
||||
# $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb
|
||||
} unpack( UNPACK, $chunk ); # cdrake
|
||||
# } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake
|
||||
|
||||
|
||||
if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake
|
||||
my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikely to ever be needed - the numbers are just too big...) # cdrake
|
||||
} else { # cdrake
|
||||
($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake
|
||||
} # cdrake
|
||||
|
||||
|
||||
my $obj = bless { %entry, %args }, $class;
|
||||
|
||||
### magic is a filetype string.. it should have something like 'ustar' or
|
||||
### something similar... if the chunk is garbage, skip it
|
||||
return unless $obj->magic !~ /\W/;
|
||||
|
||||
### store the original chunk ###
|
||||
$obj->raw( $chunk );
|
||||
|
||||
$obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
|
||||
$obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
|
||||
|
||||
|
||||
return $obj;
|
||||
|
||||
}
|
||||
|
||||
sub _new_from_file {
|
||||
my $class = shift;
|
||||
my $path = shift;
|
||||
|
||||
### path has to at least exist
|
||||
return unless defined $path;
|
||||
|
||||
my $type = __PACKAGE__->_filetype($path);
|
||||
my $data = '';
|
||||
|
||||
READ: {
|
||||
unless ($type == DIR ) {
|
||||
my $fh = IO::File->new;
|
||||
|
||||
unless( $fh->open($path) ) {
|
||||
### dangling symlinks are fine, stop reading but continue
|
||||
### creating the object
|
||||
last READ if $type == SYMLINK;
|
||||
|
||||
### otherwise, return from this function --
|
||||
### anything that's *not* a symlink should be
|
||||
### resolvable
|
||||
return;
|
||||
}
|
||||
|
||||
### binmode needed to read files properly on win32 ###
|
||||
binmode $fh;
|
||||
$data = do { local $/; <$fh> };
|
||||
close $fh;
|
||||
}
|
||||
}
|
||||
|
||||
my @items = qw[mode uid gid size mtime];
|
||||
my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
|
||||
|
||||
if (ON_VMS) {
|
||||
### VMS has two UID modes, traditional and POSIX. Normally POSIX is
|
||||
### not used. We currently do not have an easy way to see if we are in
|
||||
### POSIX mode. In traditional mode, the UID is actually the VMS UIC.
|
||||
### The VMS UIC has the upper 16 bits is the GID, which in many cases
|
||||
### the VMS UIC will be larger than 209715, the largest that TAR can
|
||||
### handle. So for now, assume it is traditional if the UID is larger
|
||||
### than 0x10000.
|
||||
|
||||
if ($hash{uid} > 0x10000) {
|
||||
$hash{uid} = $hash{uid} & 0xFFFF;
|
||||
}
|
||||
|
||||
### The file length from stat() is the physical length of the file
|
||||
### However the amount of data read in may be more for some file types.
|
||||
### Fixed length files are read past the logical EOF to end of the block
|
||||
### containing. Other file types get expanded on read because record
|
||||
### delimiters are added.
|
||||
|
||||
my $data_len = length $data;
|
||||
$hash{size} = $data_len if $hash{size} < $data_len;
|
||||
|
||||
}
|
||||
### you *must* set size == 0 on symlinks, or the next entry will be
|
||||
### though of as the contents of the symlink, which is wrong.
|
||||
### this fixes bug #7937
|
||||
$hash{size} = 0 if ($type == DIR or $type == SYMLINK);
|
||||
$hash{mtime} -= TIME_OFFSET;
|
||||
|
||||
### strip the high bits off the mode, which we don't need to store
|
||||
$hash{mode} = STRIP_MODE->( $hash{mode} );
|
||||
|
||||
|
||||
### probably requires some file path munging here ... ###
|
||||
### name and prefix are set later
|
||||
my $obj = {
|
||||
%hash,
|
||||
name => '',
|
||||
chksum => CHECK_SUM,
|
||||
type => $type,
|
||||
linkname => ($type == SYMLINK and CAN_READLINK)
|
||||
? readlink $path
|
||||
: '',
|
||||
magic => MAGIC,
|
||||
version => TAR_VERSION,
|
||||
uname => UNAME->( $hash{uid} ),
|
||||
gname => GNAME->( $hash{gid} ),
|
||||
devmajor => 0, # not handled
|
||||
devminor => 0, # not handled
|
||||
prefix => '',
|
||||
data => $data,
|
||||
};
|
||||
|
||||
bless $obj, $class;
|
||||
|
||||
### fix up the prefix and file from the path
|
||||
my($prefix,$file) = $obj->_prefix_and_file( $path );
|
||||
$obj->prefix( $prefix );
|
||||
$obj->name( $file );
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub _new_from_data {
|
||||
my $class = shift;
|
||||
my $path = shift; return unless defined $path;
|
||||
my $data = shift; return unless defined $data;
|
||||
my $opt = shift;
|
||||
|
||||
my $obj = {
|
||||
data => $data,
|
||||
name => '',
|
||||
mode => MODE,
|
||||
uid => UID,
|
||||
gid => GID,
|
||||
size => length $data,
|
||||
mtime => time - TIME_OFFSET,
|
||||
chksum => CHECK_SUM,
|
||||
type => FILE,
|
||||
linkname => '',
|
||||
magic => MAGIC,
|
||||
version => TAR_VERSION,
|
||||
uname => UNAME->( UID ),
|
||||
gname => GNAME->( GID ),
|
||||
devminor => 0,
|
||||
devmajor => 0,
|
||||
prefix => '',
|
||||
};
|
||||
|
||||
### overwrite with user options, if provided ###
|
||||
if( $opt and ref $opt eq 'HASH' ) {
|
||||
for my $key ( keys %$opt ) {
|
||||
|
||||
### don't write bogus options ###
|
||||
next unless exists $obj->{$key};
|
||||
$obj->{$key} = $opt->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
bless $obj, $class;
|
||||
|
||||
### fix up the prefix and file from the path
|
||||
my($prefix,$file) = $obj->_prefix_and_file( $path );
|
||||
$obj->prefix( $prefix );
|
||||
$obj->name( $file );
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub _prefix_and_file {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
|
||||
my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
|
||||
my @dirs = File::Spec->splitdir( $dirs );
|
||||
|
||||
### so sometimes the last element is '' -- probably when trailing
|
||||
### dir slashes are encountered... this is of course pointless,
|
||||
### so remove it
|
||||
pop @dirs while @dirs and not length $dirs[-1];
|
||||
|
||||
### if it's a directory, then $file might be empty
|
||||
$file = pop @dirs if $self->is_dir and not length $file;
|
||||
|
||||
### splitting ../ gives you the relative path in native syntax
|
||||
map { $_ = '..' if $_ eq '-' } @dirs if ON_VMS;
|
||||
|
||||
my $prefix = File::Spec::Unix->catdir(
|
||||
grep { length } $vol, @dirs
|
||||
);
|
||||
return( $prefix, $file );
|
||||
}
|
||||
|
||||
sub _filetype {
|
||||
my $self = shift;
|
||||
my $file = shift;
|
||||
|
||||
return unless defined $file;
|
||||
|
||||
return SYMLINK if (-l $file); # Symlink
|
||||
|
||||
return FILE if (-f _); # Plain file
|
||||
|
||||
return DIR if (-d _); # Directory
|
||||
|
||||
return FIFO if (-p _); # Named pipe
|
||||
|
||||
return SOCKET if (-S _); # Socket
|
||||
|
||||
return BLOCKDEV if (-b _); # Block special
|
||||
|
||||
return CHARDEV if (-c _); # Character special
|
||||
|
||||
### shouldn't happen, this is when making archives, not reading ###
|
||||
return LONGLINK if ( $file eq LONGLINK_NAME );
|
||||
|
||||
return UNKNOWN; # Something else (like what?)
|
||||
|
||||
}
|
||||
|
||||
### this method 'downgrades' a file to plain file -- this is used for
|
||||
### symlinks when FOLLOW_SYMLINKS is true.
|
||||
sub _downgrade_to_plainfile {
|
||||
my $entry = shift;
|
||||
$entry->type( FILE );
|
||||
$entry->mode( MODE );
|
||||
$entry->linkname('');
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->extract( [ $alternative_name ] )
|
||||
|
||||
Extract this object, optionally to an alternative name.
|
||||
|
||||
See C<< Archive::Tar->extract_file >> for details.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub extract {
|
||||
my $self = shift;
|
||||
|
||||
local $Carp::CarpLevel += 1;
|
||||
|
||||
return Archive::Tar->_extract_file( $self, @_ );
|
||||
}
|
||||
|
||||
=head2 $path = $file->full_path
|
||||
|
||||
Returns the full path from the tar header; this is basically a
|
||||
concatenation of the C<prefix> and C<name> fields.
|
||||
|
||||
=cut
|
||||
|
||||
sub full_path {
|
||||
my $self = shift;
|
||||
|
||||
### if prefix field is empty
|
||||
return $self->name unless defined $self->prefix and length $self->prefix;
|
||||
|
||||
### or otherwise, catfile'd
|
||||
return File::Spec::Unix->catfile( $self->prefix, $self->name );
|
||||
}
|
||||
|
||||
|
||||
=head2 $bool = $file->validate
|
||||
|
||||
Done by Archive::Tar internally when reading the tar file:
|
||||
validate the header against the checksum to ensure integer tar file.
|
||||
|
||||
Returns true on success, false on failure
|
||||
|
||||
=cut
|
||||
|
||||
sub validate {
|
||||
my $self = shift;
|
||||
|
||||
my $raw = $self->raw;
|
||||
|
||||
### don't know why this one is different from the one we /write/ ###
|
||||
substr ($raw, 148, 8) = " ";
|
||||
|
||||
### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
|
||||
### like GNU tar does. See here for details:
|
||||
### http://www.gnu.org/software/tar/manual/tar.html#SEC139
|
||||
### so we do both a signed AND unsigned validate. if one succeeds, that's
|
||||
### good enough
|
||||
return ( (unpack ("%16C*", $raw) == $self->chksum)
|
||||
or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->has_content
|
||||
|
||||
Returns a boolean to indicate whether the current object has content.
|
||||
Some special files like directories and so on never will have any
|
||||
content. This method is mainly to make sure you don't get warnings
|
||||
for using uninitialized values when looking at an object's content.
|
||||
|
||||
=cut
|
||||
|
||||
sub has_content {
|
||||
my $self = shift;
|
||||
return defined $self->data() && length $self->data() ? 1 : 0;
|
||||
}
|
||||
|
||||
=head2 $content = $file->get_content
|
||||
|
||||
Returns the current content for the in-memory file
|
||||
|
||||
=cut
|
||||
|
||||
sub get_content {
|
||||
my $self = shift;
|
||||
$self->data( );
|
||||
}
|
||||
|
||||
=head2 $cref = $file->get_content_by_ref
|
||||
|
||||
Returns the current content for the in-memory file as a scalar
|
||||
reference. Normal users won't need this, but it will save memory if
|
||||
you are dealing with very large data files in your tar archive, since
|
||||
it will pass the contents by reference, rather than make a copy of it
|
||||
first.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_content_by_ref {
|
||||
my $self = shift;
|
||||
|
||||
return \$self->{data};
|
||||
}
|
||||
|
||||
=head2 $bool = $file->replace_content( $content )
|
||||
|
||||
Replace the current content of the file with the new content. This
|
||||
only affects the in-memory archive, not the on-disk version until
|
||||
you write it.
|
||||
|
||||
Returns true on success, false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub replace_content {
|
||||
my $self = shift;
|
||||
my $data = shift || '';
|
||||
|
||||
$self->data( $data );
|
||||
$self->size( length $data );
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->rename( $new_name )
|
||||
|
||||
Rename the current file to $new_name.
|
||||
|
||||
Note that you must specify a Unix path for $new_name, since per tar
|
||||
standard, all files in the archive must be Unix paths.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub rename {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
|
||||
return unless defined $path;
|
||||
|
||||
my ($prefix,$file) = $self->_prefix_and_file( $path );
|
||||
|
||||
$self->name( $file );
|
||||
$self->prefix( $prefix );
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->chmod $mode)
|
||||
|
||||
Change mode of $file to $mode. The mode can be a string or a number
|
||||
which is interpreted as octal whether or not a leading 0 is given.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub chmod {
|
||||
my $self = shift;
|
||||
my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
|
||||
$self->{mode} = oct($mode);
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head2 $bool = $file->chown( $user [, $group])
|
||||
|
||||
Change owner of $file to $user. If a $group is given that is changed
|
||||
as well. You can also pass a single parameter with a colon separating the
|
||||
use and group as in 'root:wheel'.
|
||||
|
||||
Returns true on success and false on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub chown {
|
||||
my $self = shift;
|
||||
my $uname = shift;
|
||||
return unless defined $uname;
|
||||
my $gname;
|
||||
if (-1 != index($uname, ':')) {
|
||||
($uname, $gname) = split(/:/, $uname);
|
||||
} else {
|
||||
$gname = shift if @_ > 0;
|
||||
}
|
||||
|
||||
$self->uname( $uname );
|
||||
$self->gname( $gname ) if $gname;
|
||||
return 1;
|
||||
}
|
||||
|
||||
=head1 Convenience methods
|
||||
|
||||
To quickly check the type of a C<Archive::Tar::File> object, you can
|
||||
use the following methods:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $file->is_file
|
||||
|
||||
Returns true if the file is of type C<file>
|
||||
|
||||
=item $file->is_dir
|
||||
|
||||
Returns true if the file is of type C<dir>
|
||||
|
||||
=item $file->is_hardlink
|
||||
|
||||
Returns true if the file is of type C<hardlink>
|
||||
|
||||
=item $file->is_symlink
|
||||
|
||||
Returns true if the file is of type C<symlink>
|
||||
|
||||
=item $file->is_chardev
|
||||
|
||||
Returns true if the file is of type C<chardev>
|
||||
|
||||
=item $file->is_blockdev
|
||||
|
||||
Returns true if the file is of type C<blockdev>
|
||||
|
||||
=item $file->is_fifo
|
||||
|
||||
Returns true if the file is of type C<fifo>
|
||||
|
||||
=item $file->is_socket
|
||||
|
||||
Returns true if the file is of type C<socket>
|
||||
|
||||
=item $file->is_longlink
|
||||
|
||||
Returns true if the file is of type C<LongLink>.
|
||||
Should not happen after a successful C<read>.
|
||||
|
||||
=item $file->is_label
|
||||
|
||||
Returns true if the file is of type C<Label>.
|
||||
Should not happen after a successful C<read>.
|
||||
|
||||
=item $file->is_unknown
|
||||
|
||||
Returns true if the file type is C<unknown>
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
#stupid perl5.5.3 needs to warn if it's not numeric
|
||||
sub is_file { local $^W; FILE == $_[0]->type }
|
||||
sub is_dir { local $^W; DIR == $_[0]->type }
|
||||
sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
|
||||
sub is_symlink { local $^W; SYMLINK == $_[0]->type }
|
||||
sub is_chardev { local $^W; CHARDEV == $_[0]->type }
|
||||
sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
|
||||
sub is_fifo { local $^W; FIFO == $_[0]->type }
|
||||
sub is_socket { local $^W; SOCKET == $_[0]->type }
|
||||
sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
|
||||
sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
|
||||
sub is_label { local $^W; LABEL eq $_[0]->type }
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,939 @@
|
|||
package Attribute::Handlers;
|
||||
use 5.006;
|
||||
use Carp;
|
||||
use warnings;
|
||||
use strict;
|
||||
use vars qw($VERSION $AUTOLOAD);
|
||||
$VERSION = '0.97'; # remember to update version in POD!
|
||||
# $DB::single=1;
|
||||
|
||||
my %symcache;
|
||||
sub findsym {
|
||||
my ($pkg, $ref, $type) = @_;
|
||||
return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
|
||||
$type ||= ref($ref);
|
||||
no strict 'refs';
|
||||
my $symtab = \%{$pkg."::"};
|
||||
for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) {
|
||||
if (ref $sym && $sym == $ref) {
|
||||
return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"};
|
||||
}
|
||||
use strict;
|
||||
next unless ref ( \$sym ) eq 'GLOB';
|
||||
return $symcache{$pkg,$ref} = \$sym
|
||||
if *{$sym}{$type} && *{$sym}{$type} == $ref;
|
||||
}}
|
||||
}
|
||||
|
||||
my %validtype = (
|
||||
VAR => [qw[SCALAR ARRAY HASH]],
|
||||
ANY => [qw[SCALAR ARRAY HASH CODE]],
|
||||
"" => [qw[SCALAR ARRAY HASH CODE]],
|
||||
SCALAR => [qw[SCALAR]],
|
||||
ARRAY => [qw[ARRAY]],
|
||||
HASH => [qw[HASH]],
|
||||
CODE => [qw[CODE]],
|
||||
);
|
||||
my %lastattr;
|
||||
my @declarations;
|
||||
my %raw;
|
||||
my %phase;
|
||||
my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
|
||||
my $global_phase = 0;
|
||||
my %global_phases = (
|
||||
BEGIN => 0,
|
||||
CHECK => 1,
|
||||
INIT => 2,
|
||||
END => 3,
|
||||
);
|
||||
my @global_phases = qw(BEGIN CHECK INIT END);
|
||||
|
||||
sub _usage_AH_ {
|
||||
croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
|
||||
}
|
||||
|
||||
my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
|
||||
|
||||
sub import {
|
||||
my $class = shift @_;
|
||||
return unless $class eq "Attribute::Handlers";
|
||||
while (@_) {
|
||||
my $cmd = shift;
|
||||
if ($cmd =~ /^autotie((?:ref)?)$/) {
|
||||
my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
|
||||
my $mapping = shift;
|
||||
_usage_AH_ $class unless ref($mapping) eq 'HASH';
|
||||
while (my($attr, $tieclass) = each %$mapping) {
|
||||
$tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
|
||||
my $args = $3||'()';
|
||||
_usage_AH_ $class unless $attr =~ $qual_id
|
||||
&& $tieclass =~ $qual_id
|
||||
&& eval "use base q\0$tieclass\0; 1";
|
||||
if ($tieclass->isa('Exporter')) {
|
||||
local $Exporter::ExportLevel = 2;
|
||||
$tieclass->import(eval $args);
|
||||
}
|
||||
$attr =~ s/__CALLER__/caller(1)/e;
|
||||
$attr = caller()."::".$attr unless $attr =~ /::/;
|
||||
eval qq{
|
||||
sub $attr : ATTR(VAR) {
|
||||
my (\$ref, \$data) = \@_[2,4];
|
||||
my \$was_arrayref = ref \$data eq 'ARRAY';
|
||||
\$data = [ \$data ] unless \$was_arrayref;
|
||||
my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
|
||||
(\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
|
||||
:(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
|
||||
:(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
|
||||
: die "Can't autotie a \$type\n"
|
||||
} 1
|
||||
} or die "Internal error: $@";
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak "Can't understand $_";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# On older perls, code attribute handlers run before the sub gets placed
|
||||
# in its package. Since the :ATTR handlers need to know the name of the
|
||||
# sub they're applied to, the name lookup (via findsym) needs to be
|
||||
# delayed: we do it immediately before we might need to find attribute
|
||||
# handlers from their name. However, on newer perls (which fix some
|
||||
# problems relating to attribute application), a sub gets placed in its
|
||||
# package before its attributes are processed. In this case, the
|
||||
# delayed name lookup might be too late, because the sub we're looking
|
||||
# for might have already been replaced. So we need to detect which way
|
||||
# round this perl does things, and time the name lookup accordingly.
|
||||
BEGIN {
|
||||
my $delayed;
|
||||
sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
|
||||
$delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
|
||||
return ();
|
||||
}
|
||||
sub Attribute::Handlers::_TEST_::t :T { }
|
||||
*_delayed_name_resolution = sub() { $delayed };
|
||||
undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
|
||||
undef &Attribute::Handlers::_TEST_::t;
|
||||
}
|
||||
|
||||
sub _resolve_lastattr {
|
||||
return unless $lastattr{ref};
|
||||
my $sym = findsym @lastattr{'pkg','ref'}
|
||||
or die "Internal error: $lastattr{pkg} symbol went missing";
|
||||
my $name = *{$sym}{NAME};
|
||||
warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
|
||||
if $^W and $name !~ /[A-Z]/;
|
||||
foreach ( @{$validtype{$lastattr{type}}} ) {
|
||||
no strict 'refs';
|
||||
*{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
|
||||
}
|
||||
%lastattr = ();
|
||||
}
|
||||
|
||||
sub AUTOLOAD {
|
||||
return if $AUTOLOAD =~ /::DESTROY$/;
|
||||
my ($class) = $AUTOLOAD =~ m/(.*)::/g;
|
||||
$AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
|
||||
croak "Can't locate class method '$AUTOLOAD' via package '$class'";
|
||||
croak "Attribute handler '$2' doesn't handle $1 attributes";
|
||||
}
|
||||
|
||||
my $builtin = qr/lvalue|method|locked|unique|shared/;
|
||||
|
||||
sub _gen_handler_AH_() {
|
||||
return sub {
|
||||
_resolve_lastattr if _delayed_name_resolution;
|
||||
my ($pkg, $ref, @attrs) = @_;
|
||||
my (undef, $filename, $linenum) = caller 2;
|
||||
foreach (@attrs) {
|
||||
my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
|
||||
if ($attr eq 'ATTR') {
|
||||
no strict 'refs';
|
||||
$data ||= "ANY";
|
||||
$raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
|
||||
$phase{$ref}{BEGIN} = 1
|
||||
if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
|
||||
$phase{$ref}{INIT} = 1
|
||||
if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
|
||||
$phase{$ref}{END} = 1
|
||||
if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
|
||||
$phase{$ref}{CHECK} = 1
|
||||
if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
|
||||
|| ! keys %{$phase{$ref}};
|
||||
# Added for cleanup to not pollute next call.
|
||||
(%lastattr = ()),
|
||||
croak "Can't have two ATTR specifiers on one subroutine"
|
||||
if keys %lastattr;
|
||||
croak "Bad attribute type: ATTR($data)"
|
||||
unless $validtype{$data};
|
||||
%lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
|
||||
_resolve_lastattr unless _delayed_name_resolution;
|
||||
}
|
||||
else {
|
||||
my $type = ref $ref;
|
||||
my $handler = $pkg->can("_ATTR_${type}_${attr}");
|
||||
next unless $handler;
|
||||
my $decl = [$pkg, $ref, $attr, $data,
|
||||
$raw{$handler}, $phase{$handler}, $filename, $linenum];
|
||||
foreach my $gphase (@global_phases) {
|
||||
_apply_handler_AH_($decl,$gphase)
|
||||
if $global_phases{$gphase} <= $global_phase;
|
||||
}
|
||||
if ($global_phase != 0) {
|
||||
# if _gen_handler_AH_ is being called after
|
||||
# CHECK it's for a lexical, so make sure
|
||||
# it didn't want to run anything later
|
||||
|
||||
local $Carp::CarpLevel = 2;
|
||||
carp "Won't be able to apply END handler"
|
||||
if $phase{$handler}{END};
|
||||
}
|
||||
else {
|
||||
push @declarations, $decl
|
||||
}
|
||||
}
|
||||
$_ = undef;
|
||||
}
|
||||
return grep {defined && !/$builtin/} @attrs;
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
no strict 'refs';
|
||||
*{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
|
||||
_gen_handler_AH_ foreach @{$validtype{ANY}};
|
||||
}
|
||||
push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
|
||||
unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
|
||||
|
||||
sub _apply_handler_AH_ {
|
||||
my ($declaration, $phase) = @_;
|
||||
my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
|
||||
return unless $handlerphase->{$phase};
|
||||
# print STDERR "Handling $attr on $ref in $phase with [$data]\n";
|
||||
my $type = ref $ref;
|
||||
my $handler = "_ATTR_${type}_${attr}";
|
||||
my $sym = findsym($pkg, $ref);
|
||||
$sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
|
||||
no warnings;
|
||||
if (!$raw && defined($data)) {
|
||||
if ($data ne '') {
|
||||
my $evaled = eval("package $pkg; no warnings; no strict;
|
||||
local \$SIG{__WARN__}=sub{die}; [$data]");
|
||||
$data = $evaled unless $@;
|
||||
}
|
||||
else { $data = undef }
|
||||
}
|
||||
$pkg->$handler($sym,
|
||||
(ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
|
||||
$attr,
|
||||
$data,
|
||||
$phase,
|
||||
$filename,
|
||||
$linenum,
|
||||
);
|
||||
return 1;
|
||||
}
|
||||
|
||||
{
|
||||
no warnings 'void';
|
||||
CHECK {
|
||||
$global_phase++;
|
||||
_resolve_lastattr if _delayed_name_resolution;
|
||||
foreach my $decl (@declarations) {
|
||||
_apply_handler_AH_($decl, 'CHECK');
|
||||
}
|
||||
}
|
||||
|
||||
INIT {
|
||||
$global_phase++;
|
||||
foreach my $decl (@declarations) {
|
||||
_apply_handler_AH_($decl, 'INIT');
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
END {
|
||||
$global_phase++;
|
||||
foreach my $decl (@declarations) {
|
||||
_apply_handler_AH_($decl, 'END');
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Attribute::Handlers - Simpler definition of attribute handlers
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
This document describes version 0.97 of Attribute::Handlers.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyClass;
|
||||
require 5.006;
|
||||
use Attribute::Handlers;
|
||||
no warnings 'redefine';
|
||||
|
||||
|
||||
sub Good : ATTR(SCALAR) {
|
||||
my ($package, $symbol, $referent, $attr, $data) = @_;
|
||||
|
||||
# Invoked for any scalar variable with a :Good attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
|
||||
# Do whatever to $referent here (executed in CHECK phase).
|
||||
...
|
||||
}
|
||||
|
||||
sub Bad : ATTR(SCALAR) {
|
||||
# Invoked for any scalar variable with a :Bad attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
...
|
||||
}
|
||||
|
||||
sub Good : ATTR(ARRAY) {
|
||||
# Invoked for any array variable with a :Good attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
...
|
||||
}
|
||||
|
||||
sub Good : ATTR(HASH) {
|
||||
# Invoked for any hash variable with a :Good attribute,
|
||||
# provided the variable was declared in MyClass (or
|
||||
# a derived class) or typed to MyClass.
|
||||
...
|
||||
}
|
||||
|
||||
sub Ugly : ATTR(CODE) {
|
||||
# Invoked for any subroutine declared in MyClass (or a
|
||||
# derived class) with an :Ugly attribute.
|
||||
...
|
||||
}
|
||||
|
||||
sub Omni : ATTR {
|
||||
# Invoked for any scalar, array, hash, or subroutine
|
||||
# with an :Omni attribute, provided the variable or
|
||||
# subroutine was declared in MyClass (or a derived class)
|
||||
# or the variable was typed to MyClass.
|
||||
# Use ref($_[2]) to determine what kind of referent it was.
|
||||
...
|
||||
}
|
||||
|
||||
|
||||
use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
|
||||
|
||||
my $next : Cycle(['A'..'Z']);
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module, when inherited by a package, allows that package's class to
|
||||
define attribute handler subroutines for specific attributes. Variables
|
||||
and subroutines subsequently defined in that package, or in packages
|
||||
derived from that package may be given attributes with the same names as
|
||||
the attribute handler subroutines, which will then be called in one of
|
||||
the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
|
||||
block). (C<UNITCHECK> blocks don't correspond to a global compilation
|
||||
phase, so they can't be specified here.)
|
||||
|
||||
To create a handler, define it as a subroutine with the same name as
|
||||
the desired attribute, and declare the subroutine itself with the
|
||||
attribute C<:ATTR>. For example:
|
||||
|
||||
package LoudDecl;
|
||||
use Attribute::Handlers;
|
||||
|
||||
sub Loud :ATTR {
|
||||
my ($package, $symbol, $referent, $attr, $data, $phase,
|
||||
$filename, $linenum) = @_;
|
||||
print STDERR
|
||||
ref($referent), " ",
|
||||
*{$symbol}{NAME}, " ",
|
||||
"($referent) ", "was just declared ",
|
||||
"and ascribed the ${attr} attribute ",
|
||||
"with data ($data)\n",
|
||||
"in phase $phase\n",
|
||||
"in file $filename at line $linenum\n";
|
||||
}
|
||||
|
||||
This creates a handler for the attribute C<:Loud> in the class LoudDecl.
|
||||
Thereafter, any subroutine declared with a C<:Loud> attribute in the class
|
||||
LoudDecl:
|
||||
|
||||
package LoudDecl;
|
||||
|
||||
sub foo: Loud {...}
|
||||
|
||||
causes the above handler to be invoked, and passed:
|
||||
|
||||
=over
|
||||
|
||||
=item [0]
|
||||
|
||||
the name of the package into which it was declared;
|
||||
|
||||
=item [1]
|
||||
|
||||
a reference to the symbol table entry (typeglob) containing the subroutine;
|
||||
|
||||
=item [2]
|
||||
|
||||
a reference to the subroutine;
|
||||
|
||||
=item [3]
|
||||
|
||||
the name of the attribute;
|
||||
|
||||
=item [4]
|
||||
|
||||
any data associated with that attribute;
|
||||
|
||||
=item [5]
|
||||
|
||||
the name of the phase in which the handler is being invoked;
|
||||
|
||||
=item [6]
|
||||
|
||||
the filename in which the handler is being invoked;
|
||||
|
||||
=item [7]
|
||||
|
||||
the line number in this file.
|
||||
|
||||
=back
|
||||
|
||||
Likewise, declaring any variables with the C<:Loud> attribute within the
|
||||
package:
|
||||
|
||||
package LoudDecl;
|
||||
|
||||
my $foo :Loud;
|
||||
my @foo :Loud;
|
||||
my %foo :Loud;
|
||||
|
||||
will cause the handler to be called with a similar argument list (except,
|
||||
of course, that C<$_[2]> will be a reference to the variable).
|
||||
|
||||
The package name argument will typically be the name of the class into
|
||||
which the subroutine was declared, but it may also be the name of a derived
|
||||
class (since handlers are inherited).
|
||||
|
||||
If a lexical variable is given an attribute, there is no symbol table to
|
||||
which it belongs, so the symbol table argument (C<$_[1]>) is set to the
|
||||
string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
|
||||
an anonymous subroutine results in a symbol table argument of C<'ANON'>.
|
||||
|
||||
The data argument passes in the value (if any) associated with the
|
||||
attribute. For example, if C<&foo> had been declared:
|
||||
|
||||
sub foo :Loud("turn it up to 11, man!") {...}
|
||||
|
||||
then a reference to an array containing the string
|
||||
C<"turn it up to 11, man!"> would be passed as the last argument.
|
||||
|
||||
Attribute::Handlers makes strenuous efforts to convert
|
||||
the data argument (C<$_[4]>) to a usable form before passing it to
|
||||
the handler (but see L<"Non-interpretive attribute handlers">).
|
||||
If those efforts succeed, the interpreted data is passed in an array
|
||||
reference; if they fail, the raw data is passed as a string.
|
||||
For example, all of these:
|
||||
|
||||
sub foo :Loud(till=>ears=>are=>bleeding) {...}
|
||||
sub foo :Loud(qw/till ears are bleeding/) {...}
|
||||
sub foo :Loud(qw/till, ears, are, bleeding/) {...}
|
||||
sub foo :Loud(till,ears,are,bleeding) {...}
|
||||
|
||||
causes it to pass C<['till','ears','are','bleeding']> as the handler's
|
||||
data argument. While:
|
||||
|
||||
sub foo :Loud(['till','ears','are','bleeding']) {...}
|
||||
|
||||
causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
|
||||
reference specified in the data being passed inside the standard
|
||||
array reference indicating successful interpretation.
|
||||
|
||||
However, if the data can't be parsed as valid Perl, then
|
||||
it is passed as an uninterpreted string. For example:
|
||||
|
||||
sub foo :Loud(my,ears,are,bleeding) {...}
|
||||
sub foo :Loud(qw/my ears are bleeding) {...}
|
||||
|
||||
cause the strings C<'my,ears,are,bleeding'> and
|
||||
C<'qw/my ears are bleeding'> respectively to be passed as the
|
||||
data argument.
|
||||
|
||||
If no value is associated with the attribute, C<undef> is passed.
|
||||
|
||||
=head2 Typed lexicals
|
||||
|
||||
Regardless of the package in which it is declared, if a lexical variable is
|
||||
ascribed an attribute, the handler that is invoked is the one belonging to
|
||||
the package to which it is typed. For example, the following declarations:
|
||||
|
||||
package OtherClass;
|
||||
|
||||
my LoudDecl $loudobj : Loud;
|
||||
my LoudDecl @loudobjs : Loud;
|
||||
my LoudDecl %loudobjex : Loud;
|
||||
|
||||
causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
|
||||
defines a handler for C<:Loud> attributes).
|
||||
|
||||
|
||||
=head2 Type-specific attribute handlers
|
||||
|
||||
If an attribute handler is declared and the C<:ATTR> specifier is
|
||||
given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
|
||||
the handler is only applied to declarations of that type. For example,
|
||||
the following definition:
|
||||
|
||||
package LoudDecl;
|
||||
|
||||
sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
|
||||
|
||||
creates an attribute handler that applies only to scalars:
|
||||
|
||||
|
||||
package Painful;
|
||||
use base LoudDecl;
|
||||
|
||||
my $metal : RealLoud; # invokes &LoudDecl::RealLoud
|
||||
my @metal : RealLoud; # error: unknown attribute
|
||||
my %metal : RealLoud; # error: unknown attribute
|
||||
sub metal : RealLoud {...} # error: unknown attribute
|
||||
|
||||
You can, of course, declare separate handlers for these types as well
|
||||
(but you'll need to specify C<no warnings 'redefine'> to do it quietly):
|
||||
|
||||
package LoudDecl;
|
||||
use Attribute::Handlers;
|
||||
no warnings 'redefine';
|
||||
|
||||
sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
|
||||
sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
|
||||
sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
|
||||
sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
|
||||
|
||||
You can also explicitly indicate that a single handler is meant to be
|
||||
used for all types of referents like so:
|
||||
|
||||
package LoudDecl;
|
||||
use Attribute::Handlers;
|
||||
|
||||
sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
|
||||
|
||||
(I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
|
||||
|
||||
|
||||
=head2 Non-interpretive attribute handlers
|
||||
|
||||
Occasionally the strenuous efforts Attribute::Handlers makes to convert
|
||||
the data argument (C<$_[4]>) to a usable form before passing it to
|
||||
the handler get in the way.
|
||||
|
||||
You can turn off that eagerness-to-help by declaring
|
||||
an attribute handler with the keyword C<RAWDATA>. For example:
|
||||
|
||||
sub Raw : ATTR(RAWDATA) {...}
|
||||
sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
|
||||
sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
|
||||
|
||||
Then the handler makes absolutely no attempt to interpret the data it
|
||||
receives and simply passes it as a string:
|
||||
|
||||
my $power : Raw(1..100); # handlers receives "1..100"
|
||||
|
||||
=head2 Phase-specific attribute handlers
|
||||
|
||||
By default, attribute handlers are called at the end of the compilation
|
||||
phase (in a C<CHECK> block). This seems to be optimal in most cases because
|
||||
most things that can be defined are defined by that point but nothing has
|
||||
been executed.
|
||||
|
||||
However, it is possible to set up attribute handlers that are called at
|
||||
other points in the program's compilation or execution, by explicitly
|
||||
stating the phase (or phases) in which you wish the attribute handler to
|
||||
be called. For example:
|
||||
|
||||
sub Early :ATTR(SCALAR,BEGIN) {...}
|
||||
sub Normal :ATTR(SCALAR,CHECK) {...}
|
||||
sub Late :ATTR(SCALAR,INIT) {...}
|
||||
sub Final :ATTR(SCALAR,END) {...}
|
||||
sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
|
||||
|
||||
As the last example indicates, a handler may be set up to be (re)called in
|
||||
two or more phases. The phase name is passed as the handler's final argument.
|
||||
|
||||
Note that attribute handlers that are scheduled for the C<BEGIN> phase
|
||||
are handled as soon as the attribute is detected (i.e. before any
|
||||
subsequently defined C<BEGIN> blocks are executed).
|
||||
|
||||
|
||||
=head2 Attributes as C<tie> interfaces
|
||||
|
||||
Attributes make an excellent and intuitive interface through which to tie
|
||||
variables. For example:
|
||||
|
||||
use Attribute::Handlers;
|
||||
use Tie::Cycle;
|
||||
|
||||
sub UNIVERSAL::Cycle : ATTR(SCALAR) {
|
||||
my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
|
||||
$data = [ $data ] unless ref $data eq 'ARRAY';
|
||||
tie $$referent, 'Tie::Cycle', $data;
|
||||
}
|
||||
|
||||
# and thereafter...
|
||||
|
||||
package main;
|
||||
|
||||
my $next : Cycle('A'..'Z'); # $next is now a tied variable
|
||||
|
||||
while (<>) {
|
||||
print $next;
|
||||
}
|
||||
|
||||
Note that, because the C<Cycle> attribute receives its arguments in the
|
||||
C<$data> variable, if the attribute is given a list of arguments, C<$data>
|
||||
will consist of a single array reference; otherwise, it will consist of the
|
||||
single argument directly. Since Tie::Cycle requires its cycling values to
|
||||
be passed as an array reference, this means that we need to wrap
|
||||
non-array-reference arguments in an array constructor:
|
||||
|
||||
$data = [ $data ] unless ref $data eq 'ARRAY';
|
||||
|
||||
Typically, however, things are the other way around: the tieable class expects
|
||||
its arguments as a flattened list, so the attribute looks like:
|
||||
|
||||
sub UNIVERSAL::Cycle : ATTR(SCALAR) {
|
||||
my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
|
||||
my @data = ref $data eq 'ARRAY' ? @$data : $data;
|
||||
tie $$referent, 'Tie::Whatever', @data;
|
||||
}
|
||||
|
||||
|
||||
This software pattern is so widely applicable that Attribute::Handlers
|
||||
provides a way to automate it: specifying C<'autotie'> in the
|
||||
C<use Attribute::Handlers> statement. So, the cycling example,
|
||||
could also be written:
|
||||
|
||||
use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
|
||||
|
||||
# and thereafter...
|
||||
|
||||
package main;
|
||||
|
||||
my $next : Cycle(['A'..'Z']); # $next is now a tied variable
|
||||
|
||||
while (<>) {
|
||||
print $next;
|
||||
}
|
||||
|
||||
Note that we now have to pass the cycling values as an array reference,
|
||||
since the C<autotie> mechanism passes C<tie> a list of arguments as a list
|
||||
(as in the Tie::Whatever example), I<not> as an array reference (as in
|
||||
the original Tie::Cycle example at the start of this section).
|
||||
|
||||
The argument after C<'autotie'> is a reference to a hash in which each key is
|
||||
the name of an attribute to be created, and each value is the class to which
|
||||
variables ascribed that attribute should be tied.
|
||||
|
||||
Note that there is no longer any need to import the Tie::Cycle module --
|
||||
Attribute::Handlers takes care of that automagically. You can even pass
|
||||
arguments to the module's C<import> subroutine, by appending them to the
|
||||
class name. For example:
|
||||
|
||||
use Attribute::Handlers
|
||||
autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
|
||||
|
||||
If the attribute name is unqualified, the attribute is installed in the
|
||||
current package. Otherwise it is installed in the qualifier's package:
|
||||
|
||||
package Here;
|
||||
|
||||
use Attribute::Handlers autotie => {
|
||||
Other::Good => Tie::SecureHash, # tie attr installed in Other::
|
||||
Bad => Tie::Taxes, # tie attr installed in Here::
|
||||
UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
|
||||
};
|
||||
|
||||
Autoties are most commonly used in the module to which they actually tie,
|
||||
and need to export their attributes to any module that calls them. To
|
||||
facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
|
||||
C<__CALLER__>, which may be specified as the qualifier of an attribute:
|
||||
|
||||
package Tie::Me::Kangaroo:Down::Sport;
|
||||
|
||||
use Attribute::Handlers autotie =>
|
||||
{ '__CALLER__::Roo' => __PACKAGE__ };
|
||||
|
||||
This causes Attribute::Handlers to define the C<Roo> attribute in the package
|
||||
that imports the Tie::Me::Kangaroo:Down::Sport module.
|
||||
|
||||
Note that it is important to quote the __CALLER__::Roo identifier because
|
||||
a bug in perl 5.8 will refuse to parse it and cause an unknown error.
|
||||
|
||||
=head3 Passing the tied object to C<tie>
|
||||
|
||||
Occasionally it is important to pass a reference to the object being tied
|
||||
to the TIESCALAR, TIEHASH, etc. that ties it.
|
||||
|
||||
The C<autotie> mechanism supports this too. The following code:
|
||||
|
||||
use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
|
||||
my $var : Selfish(@args);
|
||||
|
||||
has the same effect as:
|
||||
|
||||
tie my $var, 'Tie::Selfish', @args;
|
||||
|
||||
But when C<"autotieref"> is used instead of C<"autotie">:
|
||||
|
||||
use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
|
||||
my $var : Selfish(@args);
|
||||
|
||||
the effect is to pass the C<tie> call an extra reference to the variable
|
||||
being tied:
|
||||
|
||||
tie my $var, 'Tie::Selfish', \$var, @args;
|
||||
|
||||
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
If the class shown in L</SYNOPSIS> were placed in the MyClass.pm
|
||||
module, then the following code:
|
||||
|
||||
package main;
|
||||
use MyClass;
|
||||
|
||||
my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
|
||||
|
||||
package SomeOtherClass;
|
||||
use base MyClass;
|
||||
|
||||
sub tent { 'acle' }
|
||||
|
||||
sub fn :Ugly(sister) :Omni('po',tent()) {...}
|
||||
my @arr :Good :Omni(s/cie/nt/);
|
||||
my %hsh :Good(q/bye/) :Omni(q/bus/);
|
||||
|
||||
|
||||
would cause the following handlers to be invoked:
|
||||
|
||||
# my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
|
||||
|
||||
MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\$slr, # referent
|
||||
'Good', # attr name
|
||||
undef # no attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\$slr, # referent
|
||||
'Bad', # attr name
|
||||
0 # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\$slr, # referent
|
||||
'Omni', # attr name
|
||||
'-vorous' # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
# sub fn :Ugly(sister) :Omni('po',tent()) {...}
|
||||
|
||||
MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
|
||||
\*SomeOtherClass::fn, # typeglob
|
||||
\&SomeOtherClass::fn, # referent
|
||||
'Ugly', # attr name
|
||||
'sister' # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
|
||||
\*SomeOtherClass::fn, # typeglob
|
||||
\&SomeOtherClass::fn, # referent
|
||||
'Omni', # attr name
|
||||
['po','acle'] # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
# my @arr :Good :Omni(s/cie/nt/);
|
||||
|
||||
MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\@arr, # referent
|
||||
'Good', # attr name
|
||||
undef # no attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\@arr, # referent
|
||||
'Omni', # attr name
|
||||
"" # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
# my %hsh :Good(q/bye) :Omni(q/bus/);
|
||||
|
||||
MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\%hsh, # referent
|
||||
'Good', # attr name
|
||||
'q/bye' # raw attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
|
||||
'LEXICAL', # no typeglob
|
||||
\%hsh, # referent
|
||||
'Omni', # attr name
|
||||
'bus' # eval'd attr data
|
||||
'CHECK', # compiler phase
|
||||
);
|
||||
|
||||
|
||||
Installing handlers into UNIVERSAL, makes them...err..universal.
|
||||
For example:
|
||||
|
||||
package Descriptions;
|
||||
use Attribute::Handlers;
|
||||
|
||||
my %name;
|
||||
sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
|
||||
|
||||
sub UNIVERSAL::Name :ATTR {
|
||||
$name{$_[2]} = $_[4];
|
||||
}
|
||||
|
||||
sub UNIVERSAL::Purpose :ATTR {
|
||||
print STDERR "Purpose of ", &name, " is $_[4]\n";
|
||||
}
|
||||
|
||||
sub UNIVERSAL::Unit :ATTR {
|
||||
print STDERR &name, " measured in $_[4]\n";
|
||||
}
|
||||
|
||||
Let's you write:
|
||||
|
||||
use Descriptions;
|
||||
|
||||
my $capacity : Name(capacity)
|
||||
: Purpose(to store max storage capacity for files)
|
||||
: Unit(Gb);
|
||||
|
||||
|
||||
package Other;
|
||||
|
||||
sub foo : Purpose(to foo all data before barring it) { }
|
||||
|
||||
# etc.
|
||||
|
||||
=head1 UTILITY FUNCTIONS
|
||||
|
||||
This module offers a single utility function, C<findsym()>.
|
||||
|
||||
=over 4
|
||||
|
||||
=item findsym
|
||||
|
||||
my $symbol = Attribute::Handlers::findsym($package, $referent);
|
||||
|
||||
The function looks in the symbol table of C<$package> for the typeglob for
|
||||
C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
|
||||
HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
|
||||
undef. Note that C<findsym> memoizes the typeglobs it has previously
|
||||
successfully found, so subsequent calls with the same arguments should be
|
||||
much faster.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over
|
||||
|
||||
=item C<Bad attribute type: ATTR(%s)>
|
||||
|
||||
An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
|
||||
type of referent it was defined to handle wasn't one of the five permitted:
|
||||
C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
|
||||
|
||||
=item C<Attribute handler %s doesn't handle %s attributes>
|
||||
|
||||
A handler for attributes of the specified name I<was> defined, but not
|
||||
for the specified type of declaration. Typically encountered when trying
|
||||
to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
|
||||
attribute handler to some other type of variable.
|
||||
|
||||
=item C<Declaration of %s attribute in package %s may clash with future reserved word>
|
||||
|
||||
A handler for an attributes with an all-lowercase name was declared. An
|
||||
attribute with an all-lowercase name might have a meaning to Perl
|
||||
itself some day, even though most don't yet. Use a mixed-case attribute
|
||||
name, instead.
|
||||
|
||||
=item C<Can't have two ATTR specifiers on one subroutine>
|
||||
|
||||
You just can't, okay?
|
||||
Instead, put all the specifications together with commas between them
|
||||
in a single C<ATTR(I<specification>)>.
|
||||
|
||||
=item C<Can't autotie a %s>
|
||||
|
||||
You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
|
||||
C<"HASH">. They're the only things (apart from typeglobs -- which are
|
||||
not declarable) that Perl can tie.
|
||||
|
||||
=item C<Internal error: %s symbol went missing>
|
||||
|
||||
Something is rotten in the state of the program. An attributed
|
||||
subroutine ceased to exist between the point it was declared and the point
|
||||
at which its attribute handler(s) would have been called.
|
||||
|
||||
=item C<Won't be able to apply END handler>
|
||||
|
||||
You have defined an END handler for an attribute that is being applied
|
||||
to a lexical variable. Since the variable may not be available during END
|
||||
this won't happen.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
|
||||
Garcia-Suarez (rgarciasuarez@gmail.com).
|
||||
|
||||
Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
|
||||
Contact him with technical difficulties with respect to the packaging of the
|
||||
CPAN module.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
|
||||
Bug reports and other feedback are most welcome.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2001-2014, Damian Conway. All Rights Reserved.
|
||||
This module is free software. It may be used, redistributed
|
||||
and/or modified under the same terms as Perl itself.
|
||||
|
|
@ -0,0 +1,453 @@
|
|||
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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
AutoLoader - load subroutines only on demand
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Foo;
|
||||
use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
|
||||
|
||||
package Bar;
|
||||
use AutoLoader; # don't import AUTOLOAD, define our own
|
||||
sub AUTOLOAD {
|
||||
...
|
||||
$AutoLoader::AUTOLOAD = "...";
|
||||
goto &AutoLoader::AUTOLOAD;
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<AutoLoader> module works with the B<AutoSplit> module and the
|
||||
C<__END__> token to defer the loading of some subroutines until they are
|
||||
used rather than loading them all at once.
|
||||
|
||||
To use B<AutoLoader>, the author of a module has to place the
|
||||
definitions of subroutines to be autoloaded after an C<__END__> token.
|
||||
(See L<perldata>.) The B<AutoSplit> module can then be run manually to
|
||||
extract the definitions into individual files F<auto/funcname.al>.
|
||||
|
||||
B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
|
||||
subroutine in is called in a client module of B<AutoLoader>,
|
||||
B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
|
||||
file with a name related to the location of the file from which the
|
||||
client module was read. As an example, if F<POSIX.pm> is located in
|
||||
F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
|
||||
subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
|
||||
the C<.al> file has the same name as the subroutine, sans package. If
|
||||
such a file exists, AUTOLOAD will read and evaluate it,
|
||||
thus (presumably) defining the needed subroutine. AUTOLOAD will then
|
||||
C<goto> the newly defined subroutine.
|
||||
|
||||
Once this process completes for a given function, it is defined, so
|
||||
future calls to the subroutine will bypass the AUTOLOAD mechanism.
|
||||
|
||||
=head2 Subroutine Stubs
|
||||
|
||||
In order for object method lookup and/or prototype checking to operate
|
||||
correctly even when methods have not yet been defined it is necessary to
|
||||
"forward declare" each subroutine (as in C<sub NAME;>). See
|
||||
L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
|
||||
stubs", which are place holders with no code.
|
||||
|
||||
The AutoSplit and B<AutoLoader> modules automate the creation of forward
|
||||
declarations. The AutoSplit module creates an 'index' file containing
|
||||
forward declarations of all the AutoSplit subroutines. When the
|
||||
AutoLoader module is 'use'd it loads these declarations into its callers
|
||||
package.
|
||||
|
||||
Because of this mechanism it is important that B<AutoLoader> is always
|
||||
C<use>d and not C<require>d.
|
||||
|
||||
=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
|
||||
|
||||
In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
|
||||
explicitly import it:
|
||||
|
||||
use AutoLoader 'AUTOLOAD';
|
||||
|
||||
=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
|
||||
|
||||
Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
|
||||
They typically need to check for some special cases (such as constants)
|
||||
and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
|
||||
|
||||
Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
|
||||
Instead, they should define their own AUTOLOAD subroutines along these
|
||||
lines:
|
||||
|
||||
use AutoLoader;
|
||||
use Carp;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $sub = $AUTOLOAD;
|
||||
(my $constname = $sub) =~ s/.*:://;
|
||||
my $val = constant($constname, @_ ? $_[0] : 0);
|
||||
if ($! != 0) {
|
||||
if ($! =~ /Invalid/ || $!{EINVAL}) {
|
||||
$AutoLoader::AUTOLOAD = $sub;
|
||||
goto &AutoLoader::AUTOLOAD;
|
||||
}
|
||||
else {
|
||||
croak "Your vendor has not defined constant $constname";
|
||||
}
|
||||
}
|
||||
*$sub = sub { $val }; # same as: eval "sub $sub { $val }";
|
||||
goto &$sub;
|
||||
}
|
||||
|
||||
If any module's own AUTOLOAD subroutine has no need to fallback to the
|
||||
AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
|
||||
subroutines), then that module should not use B<AutoLoader> at all.
|
||||
|
||||
=head2 Package Lexicals
|
||||
|
||||
Package lexicals declared with C<my> in the main block of a package
|
||||
using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
|
||||
the fact that the given scope ends at the C<__END__> marker. A module
|
||||
using such variables as package globals will not work properly under the
|
||||
B<AutoLoader>.
|
||||
|
||||
The C<vars> pragma (see L<perlmod/"vars">) may be used in such
|
||||
situations as an alternative to explicitly qualifying all globals with
|
||||
the package namespace. Variables pre-declared with this pragma will be
|
||||
visible to any autoloaded routines (but will not be invisible outside
|
||||
the package, unfortunately).
|
||||
|
||||
=head2 Not Using AutoLoader
|
||||
|
||||
You can stop using AutoLoader by simply
|
||||
|
||||
no AutoLoader;
|
||||
|
||||
=head2 B<AutoLoader> vs. B<SelfLoader>
|
||||
|
||||
The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
|
||||
loading of subroutines.
|
||||
|
||||
B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
|
||||
While this avoids the use of a hierarchy of disk files and the
|
||||
associated open/close for each routine loaded, B<SelfLoader> suffers a
|
||||
startup speed disadvantage in the one-time parsing of the lines after
|
||||
C<__DATA__>, after which routines are cached. B<SelfLoader> can also
|
||||
handle multiple packages in a file.
|
||||
|
||||
B<AutoLoader> only reads code as it is requested, and in many cases
|
||||
should be faster, but requires a mechanism like B<AutoSplit> be used to
|
||||
create the individual files. L<ExtUtils::MakeMaker> will invoke
|
||||
B<AutoSplit> automatically if B<AutoLoader> is used in a module source
|
||||
file.
|
||||
|
||||
=head2 Forcing AutoLoader to Load a Function
|
||||
|
||||
Sometimes, it can be necessary or useful to make sure that a certain
|
||||
function is fully loaded by AutoLoader. This is the case, for example,
|
||||
when you need to wrap a function to inject debugging code. It is also
|
||||
helpful to force early loading of code before forking to make use of
|
||||
copy-on-write as much as possible.
|
||||
|
||||
Starting with AutoLoader 5.73, you can call the
|
||||
C<AutoLoader::autoload_sub> function with the fully-qualified name of
|
||||
the function to load from its F<.al> file. The behaviour is exactly
|
||||
the same as if you called the function, triggering the regular
|
||||
C<AUTOLOAD> mechanism, but it does not actually execute the
|
||||
autoloaded function.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
|
||||
old modules which use B<AutoLoader> should be changed to the new calling
|
||||
style. Typically this just means changing a require to a use, adding
|
||||
the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
|
||||
from C<@ISA>.
|
||||
|
||||
On systems with restrictions on file name length, the file corresponding
|
||||
to a subroutine may have a shorter name that the routine itself. This
|
||||
can lead to conflicting file names. The I<AutoSplit> package warns of
|
||||
these potential conflicts when used to split a module.
|
||||
|
||||
AutoLoader may fail to find the autosplit files (or even find the wrong
|
||||
ones) in cases where C<@INC> contains relative paths, B<and> the program
|
||||
does C<chdir>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<SelfLoader> - an autoloader that doesn't use external files.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
C<AutoLoader> is maintained by the perl5-porters. Please direct
|
||||
any questions to the canonical mailing list. Anything that
|
||||
is applicable to the CPAN release can be sent to its maintainer,
|
||||
though.
|
||||
|
||||
Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
|
||||
|
||||
Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This package has been part of the perl core since the first release
|
||||
of perl5. It has been released separately to CPAN so older installations
|
||||
can benefit from bug fixes.
|
||||
|
||||
This package has the same copyright and license as the perl core:
|
||||
|
||||
Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
|
||||
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
|
||||
2011, 2012, 2013
|
||||
by Larry Wall and others
|
||||
|
||||
All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of either:
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
|
||||
b) the "Artistic License" which comes with this Kit.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
|
||||
the GNU General Public License or the Artistic License for more details.
|
||||
|
||||
You should have received a copy of the Artistic License with this
|
||||
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
|
||||
|
||||
You should also have received a copy of the GNU General Public License
|
||||
along with this program in the file named "Copying". If not, write to the
|
||||
Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
|
||||
MA 02110-1301, USA or visit their web page on the internet at
|
||||
http://www.gnu.org/copyleft/gpl.html.
|
||||
|
||||
For those of you that choose to use the GNU General Public License,
|
||||
my interpretation of the GNU General Public License is that no Perl
|
||||
script falls under the terms of the GPL unless you explicitly put
|
||||
said script under the terms of the GPL yourself. Furthermore, any
|
||||
object code linked with perl does not automatically fall under the
|
||||
terms of the GPL, provided such object code only adds definitions
|
||||
of subroutines and variables, and does not otherwise impair the
|
||||
resulting interpreter from executing any standard Perl script. I
|
||||
consider linking in C subroutines in this manner to be the moral
|
||||
equivalent of defining subroutines in the Perl language itself. You
|
||||
may sell such an object file as proprietary provided that you provide
|
||||
or offer to provide the Perl source, as specified by the GNU General
|
||||
Public License. (This is merely an alternate way of specifying input
|
||||
to the program.) You may also sell a binary produced by the dumping of
|
||||
a running Perl script that belongs to you, provided that you provide or
|
||||
offer to provide the Perl source as specified by the GPL. (The
|
||||
fact that a Perl interpreter and your code are in the same binary file
|
||||
is, in this case, a form of mere aggregation.) This is my interpretation
|
||||
of the GPL. If you still have concerns or difficulties understanding
|
||||
my intent, feel free to contact me. Of course, the Artistic License
|
||||
spells all this out for your protection, so you may prefer to use that.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,592 @@
|
|||
package AutoSplit;
|
||||
|
||||
use Exporter ();
|
||||
use Config qw(%Config);
|
||||
use File::Basename ();
|
||||
use File::Path qw(mkpath);
|
||||
use File::Spec::Functions qw(curdir catfile catdir);
|
||||
use strict;
|
||||
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
|
||||
$CheckForAutoloader, $CheckModTime);
|
||||
|
||||
$VERSION = "1.06";
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(&autosplit &autosplit_lib_modules);
|
||||
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
AutoSplit - split a package for autoloading
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
autosplit($file, $dir, $keep, $check, $modtime);
|
||||
|
||||
autosplit_lib_modules(@modules);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This function will split up your program into files that the AutoLoader
|
||||
module can handle. It is used by both the standard perl libraries and by
|
||||
the MakeMaker utility, to automatically configure libraries for autoloading.
|
||||
|
||||
The C<autosplit> interface splits the specified file into a hierarchy
|
||||
rooted at the directory C<$dir>. It creates directories as needed to reflect
|
||||
class hierarchy, and creates the file F<autosplit.ix>. This file acts as
|
||||
both forward declaration of all package routines, and as timestamp for the
|
||||
last update of the hierarchy.
|
||||
|
||||
The remaining three arguments to C<autosplit> govern other options to
|
||||
the autosplitter.
|
||||
|
||||
=over 2
|
||||
|
||||
=item $keep
|
||||
|
||||
If the third argument, I<$keep>, is false, then any
|
||||
pre-existing C<*.al> files in the autoload directory are removed if
|
||||
they are no longer part of the module (obsoleted functions).
|
||||
$keep defaults to 0.
|
||||
|
||||
=item $check
|
||||
|
||||
The
|
||||
fourth argument, I<$check>, instructs C<autosplit> to check the module
|
||||
currently being split to ensure that it includes a C<use>
|
||||
specification for the AutoLoader module, and skips the module if
|
||||
AutoLoader is not detected.
|
||||
$check defaults to 1.
|
||||
|
||||
=item $modtime
|
||||
|
||||
Lastly, the I<$modtime> argument specifies
|
||||
that C<autosplit> is to check the modification time of the module
|
||||
against that of the C<autosplit.ix> file, and only split the module if
|
||||
it is newer.
|
||||
$modtime defaults to 1.
|
||||
|
||||
=back
|
||||
|
||||
Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
|
||||
with:
|
||||
|
||||
perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
|
||||
|
||||
Defined as a Make macro, it is invoked with file and directory arguments;
|
||||
C<autosplit> will split the specified file into the specified directory and
|
||||
delete obsolete C<.al> files, after checking first that the module does use
|
||||
the AutoLoader, and ensuring that the module is not already currently split
|
||||
in its current form (the modtime test).
|
||||
|
||||
The C<autosplit_lib_modules> form is used in the building of perl. It takes
|
||||
as input a list of files (modules) that are assumed to reside in a directory
|
||||
B<lib> relative to the current directory. Each file is sent to the
|
||||
autosplitter one at a time, to be split into the directory B<lib/auto>.
|
||||
|
||||
In both usages of the autosplitter, only subroutines defined following the
|
||||
perl I<__END__> token are split out into separate files. Some
|
||||
routines may be placed prior to this marker to force their immediate loading
|
||||
and parsing.
|
||||
|
||||
=head2 Multiple packages
|
||||
|
||||
As of version 1.01 of the AutoSplit module it is possible to have
|
||||
multiple packages within a single file. Both of the following cases
|
||||
are supported:
|
||||
|
||||
package NAME;
|
||||
__END__
|
||||
sub AAA { ... }
|
||||
package NAME::option1;
|
||||
sub BBB { ... }
|
||||
package NAME::option2;
|
||||
sub BBB { ... }
|
||||
|
||||
package NAME;
|
||||
__END__
|
||||
sub AAA { ... }
|
||||
sub NAME::option1::BBB { ... }
|
||||
sub NAME::option2::BBB { ... }
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
C<AutoSplit> will inform the user if it is necessary to create the
|
||||
top-level directory specified in the invocation. It is preferred that
|
||||
the script or installation process that invokes C<AutoSplit> have
|
||||
created the full directory path ahead of time. This warning may
|
||||
indicate that the module is being split into an incorrect path.
|
||||
|
||||
C<AutoSplit> will warn the user of all subroutines whose name causes
|
||||
potential file naming conflicts on machines with drastically limited
|
||||
(8 characters or less) file name length. Since the subroutine name is
|
||||
used as the file name, these warnings can aid in portability to such
|
||||
systems.
|
||||
|
||||
Warnings are issued and the file skipped if C<AutoSplit> cannot locate
|
||||
either the I<__END__> marker or a "package Name;"-style specification.
|
||||
|
||||
C<AutoSplit> will also emit general diagnostics for inability to
|
||||
create directories or files.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
C<AutoSplit> is maintained by the perl5-porters. Please direct
|
||||
any questions to the canonical mailing list. Anything that
|
||||
is applicable to the CPAN release can be sent to its maintainer,
|
||||
though.
|
||||
|
||||
Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
|
||||
|
||||
Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This package has been part of the perl core since the first release
|
||||
of perl5. It has been released separately to CPAN so older installations
|
||||
can benefit from bug fixes.
|
||||
|
||||
This package has the same copyright and license as the perl core:
|
||||
|
||||
Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
|
||||
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
|
||||
by Larry Wall and others
|
||||
|
||||
All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of either:
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
|
||||
b) the "Artistic License" which comes with this Kit.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
|
||||
the GNU General Public License or the Artistic License for more details.
|
||||
|
||||
You should have received a copy of the Artistic License with this
|
||||
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
|
||||
|
||||
You should also have received a copy of the GNU General Public License
|
||||
along with this program in the file named "Copying". If not, write to the
|
||||
Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
|
||||
02111-1307, USA or visit their web page on the internet at
|
||||
http://www.gnu.org/copyleft/gpl.html.
|
||||
|
||||
For those of you that choose to use the GNU General Public License,
|
||||
my interpretation of the GNU General Public License is that no Perl
|
||||
script falls under the terms of the GPL unless you explicitly put
|
||||
said script under the terms of the GPL yourself. Furthermore, any
|
||||
object code linked with perl does not automatically fall under the
|
||||
terms of the GPL, provided such object code only adds definitions
|
||||
of subroutines and variables, and does not otherwise impair the
|
||||
resulting interpreter from executing any standard Perl script. I
|
||||
consider linking in C subroutines in this manner to be the moral
|
||||
equivalent of defining subroutines in the Perl language itself. You
|
||||
may sell such an object file as proprietary provided that you provide
|
||||
or offer to provide the Perl source, as specified by the GNU General
|
||||
Public License. (This is merely an alternate way of specifying input
|
||||
to the program.) You may also sell a binary produced by the dumping of
|
||||
a running Perl script that belongs to you, provided that you provide or
|
||||
offer to provide the Perl source as specified by the GPL. (The
|
||||
fact that a Perl interpreter and your code are in the same binary file
|
||||
is, in this case, a form of mere aggregation.) This is my interpretation
|
||||
of the GPL. If you still have concerns or difficulties understanding
|
||||
my intent, feel free to contact me. Of course, the Artistic License
|
||||
spells all this out for your protection, so you may prefer to use that.
|
||||
|
||||
=cut
|
||||
|
||||
# for portability warn about names longer than $maxlen
|
||||
$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
|
||||
$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
|
||||
$Keep = 0;
|
||||
$CheckForAutoloader = 1;
|
||||
$CheckModTime = 1;
|
||||
|
||||
my $IndexFile = "autosplit.ix"; # file also serves as timestamp
|
||||
my $maxflen = 255;
|
||||
$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
|
||||
if (defined (&Dos::UseLFN)) {
|
||||
$maxflen = Dos::UseLFN() ? 255 : 11;
|
||||
}
|
||||
my $Is_VMS = ($^O eq 'VMS');
|
||||
|
||||
# allow checking for valid ': attrlist' attachments.
|
||||
# extra jugglery required to support both 5.8 and 5.9/5.10 features
|
||||
# (support for 5.8 required for cross-compiling environments)
|
||||
|
||||
my $attr_list =
|
||||
$] >= 5.009005 ?
|
||||
eval <<'__QR__'
|
||||
qr{
|
||||
\s* : \s*
|
||||
(?:
|
||||
# one attribute
|
||||
(?> # no backtrack
|
||||
(?! \d) \w+
|
||||
(?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
|
||||
)
|
||||
(?: \s* : \s* | \s+ (?! :) )
|
||||
)*
|
||||
}x
|
||||
__QR__
|
||||
:
|
||||
do {
|
||||
# In pre-5.9.5 world we have to do dirty tricks.
|
||||
# (we use 'our' rather than 'my' here, due to the rather complex and buggy
|
||||
# behaviour of lexicals with qr// and (??{$lex}) )
|
||||
our $trick1; # yes, cannot our and assign at the same time.
|
||||
$trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
|
||||
our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
|
||||
qr{ \s* : \s* (?: $trick2 )* }x;
|
||||
};
|
||||
|
||||
sub autosplit{
|
||||
my($file, $autodir, $keep, $ckal, $ckmt) = @_;
|
||||
# $file - the perl source file to be split (after __END__)
|
||||
# $autodir - the ".../auto" dir below which to write split subs
|
||||
# Handle optional flags:
|
||||
$keep = $Keep unless defined $keep;
|
||||
$ckal = $CheckForAutoloader unless defined $ckal;
|
||||
$ckmt = $CheckModTime unless defined $ckmt;
|
||||
autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
|
||||
}
|
||||
|
||||
sub carp{
|
||||
require Carp;
|
||||
goto &Carp::carp;
|
||||
}
|
||||
|
||||
# This function is used during perl building/installation
|
||||
# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
|
||||
|
||||
sub autosplit_lib_modules {
|
||||
my(@modules) = @_; # list of Module names
|
||||
local $_; # Avoid clobber.
|
||||
while (defined($_ = shift @modules)) {
|
||||
while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
|
||||
$_ = catfile($1, $2);
|
||||
}
|
||||
s|\\|/|g; # bug in ksh OS/2
|
||||
s#^lib/##s; # incase specified as lib/*.pm
|
||||
my($lib) = catfile(curdir(), "lib");
|
||||
if ($Is_VMS) { # may need to convert VMS-style filespecs
|
||||
$lib =~ s#^\[\]#.\/#;
|
||||
}
|
||||
s#^$lib\W+##s; # incase specified as ./lib/*.pm
|
||||
if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
|
||||
my ($dir,$name) = (/(.*])(.*)/s);
|
||||
$dir =~ s/.*lib[\.\]]//s;
|
||||
$dir =~ s#[\.\]]#/#g;
|
||||
$_ = $dir . $name;
|
||||
}
|
||||
autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
|
||||
$Keep, $CheckForAutoloader, $CheckModTime);
|
||||
}
|
||||
0;
|
||||
}
|
||||
|
||||
|
||||
# private functions
|
||||
|
||||
my $self_mod_time = (stat __FILE__)[9];
|
||||
|
||||
sub autosplit_file {
|
||||
my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
|
||||
= @_;
|
||||
my(@outfiles);
|
||||
local($_);
|
||||
local($/) = "\n";
|
||||
|
||||
# where to write output files
|
||||
$autodir ||= catfile(curdir(), "lib", "auto");
|
||||
if ($Is_VMS) {
|
||||
($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
|
||||
$filename = VMS::Filespec::unixify($filename); # may have dirs
|
||||
}
|
||||
unless (-d $autodir){
|
||||
mkpath($autodir,0,0755);
|
||||
# We should never need to create the auto dir
|
||||
# here. installperl (or similar) should have done
|
||||
# it. Expecting it to exist is a valuable sanity check against
|
||||
# autosplitting into some random directory by mistake.
|
||||
print "Warning: AutoSplit had to create top-level " .
|
||||
"$autodir unexpectedly.\n";
|
||||
}
|
||||
|
||||
# allow just a package name to be used
|
||||
$filename .= ".pm" unless ($filename =~ m/\.pm\z/);
|
||||
|
||||
open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
|
||||
my($pm_mod_time) = (stat($filename))[9];
|
||||
my($autoloader_seen) = 0;
|
||||
my($in_pod) = 0;
|
||||
my($def_package,$last_package,$this_package,$fnr);
|
||||
while (<$in>) {
|
||||
# Skip pod text.
|
||||
$fnr++;
|
||||
$in_pod = 1 if /^=\w/;
|
||||
$in_pod = 0 if /^=cut/;
|
||||
next if ($in_pod || /^=cut/);
|
||||
next if /^\s*#/;
|
||||
|
||||
# record last package name seen
|
||||
$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
|
||||
++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
|
||||
++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
|
||||
last if /^__END__/;
|
||||
}
|
||||
if ($check_for_autoloader && !$autoloader_seen){
|
||||
print "AutoSplit skipped $filename: no AutoLoader used\n"
|
||||
if ($Verbose>=2);
|
||||
return 0;
|
||||
}
|
||||
$_ or die "Can't find __END__ in $filename\n";
|
||||
|
||||
$def_package or die "Can't find 'package Name;' in $filename\n";
|
||||
|
||||
my($modpname) = _modpname($def_package);
|
||||
|
||||
# this _has_ to match so we have a reasonable timestamp file
|
||||
die "Package $def_package ($modpname.pm) does not ".
|
||||
"match filename $filename"
|
||||
unless ($filename =~ m/\Q$modpname.pm\E$/ or
|
||||
($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
|
||||
$Is_VMS && $filename =~ m/$modpname.pm/i);
|
||||
|
||||
my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
|
||||
|
||||
if ($check_mod_time){
|
||||
my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
|
||||
if ($al_ts_time >= $pm_mod_time and
|
||||
$al_ts_time >= $self_mod_time){
|
||||
print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
|
||||
if ($Verbose >= 2);
|
||||
return undef; # one undef, not a list
|
||||
}
|
||||
}
|
||||
|
||||
my($modnamedir) = catdir($autodir, $modpname);
|
||||
print "AutoSplitting $filename ($modnamedir)\n"
|
||||
if $Verbose;
|
||||
|
||||
unless (-d $modnamedir){
|
||||
mkpath($modnamedir,0,0777);
|
||||
}
|
||||
|
||||
# We must try to deal with some SVR3 systems with a limit of 14
|
||||
# characters for file names. Sadly we *cannot* simply truncate all
|
||||
# file names to 14 characters on these systems because we *must*
|
||||
# create filenames which exactly match the names used by AutoLoader.pm.
|
||||
# This is a problem because some systems silently truncate the file
|
||||
# names while others treat long file names as an error.
|
||||
|
||||
my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
|
||||
|
||||
my(@subnames, $subname, %proto, %package);
|
||||
my @cache = ();
|
||||
my $caching = 1;
|
||||
$last_package = '';
|
||||
my $out;
|
||||
while (<$in>) {
|
||||
$fnr++;
|
||||
$in_pod = 1 if /^=\w/;
|
||||
$in_pod = 0 if /^=cut/;
|
||||
next if ($in_pod || /^=cut/);
|
||||
# the following (tempting) old coding gives big troubles if a
|
||||
# cut is forgotten at EOF:
|
||||
# next if /^=\w/ .. /^=cut/;
|
||||
if (/^package\s+([\w:]+)\s*;/) {
|
||||
$this_package = $def_package = $1;
|
||||
}
|
||||
|
||||
if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
|
||||
print $out "# end of $last_package\::$subname\n1;\n"
|
||||
if $last_package;
|
||||
$subname = $1;
|
||||
my $proto = $2 || '';
|
||||
if ($subname =~ s/(.*):://){
|
||||
$this_package = $1;
|
||||
} else {
|
||||
$this_package = $def_package;
|
||||
}
|
||||
my $fq_subname = "$this_package\::$subname";
|
||||
$package{$fq_subname} = $this_package;
|
||||
$proto{$fq_subname} = $proto;
|
||||
push(@subnames, $fq_subname);
|
||||
my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
|
||||
$modpname = _modpname($this_package);
|
||||
my($modnamedir) = catdir($autodir, $modpname);
|
||||
mkpath($modnamedir,0,0777);
|
||||
my($lpath) = catfile($modnamedir, "$lname.al");
|
||||
my($spath) = catfile($modnamedir, "$sname.al");
|
||||
my $path;
|
||||
|
||||
if (!$Is83 and open($out, ">$lpath")){
|
||||
$path=$lpath;
|
||||
print " writing $lpath\n" if ($Verbose>=2);
|
||||
} else {
|
||||
open($out, ">$spath") or die "Can't create $spath: $!\n";
|
||||
$path=$spath;
|
||||
print " writing $spath (with truncated name)\n"
|
||||
if ($Verbose>=1);
|
||||
}
|
||||
push(@outfiles, $path);
|
||||
my $lineno = $fnr - @cache;
|
||||
print $out <<EOT;
|
||||
# NOTE: Derived from $filename.
|
||||
# Changes made here will be lost when autosplit is run again.
|
||||
# See AutoSplit.pm.
|
||||
package $this_package;
|
||||
|
||||
#line $lineno "$filename (autosplit into $path)"
|
||||
EOT
|
||||
print $out @cache;
|
||||
@cache = ();
|
||||
$caching = 0;
|
||||
}
|
||||
if($caching) {
|
||||
push(@cache, $_) if @cache || /\S/;
|
||||
} else {
|
||||
print $out $_;
|
||||
}
|
||||
if(/^\}/) {
|
||||
if($caching) {
|
||||
print $out @cache;
|
||||
@cache = ();
|
||||
}
|
||||
print $out "\n";
|
||||
$caching = 1;
|
||||
}
|
||||
$last_package = $this_package if defined $this_package;
|
||||
}
|
||||
if ($subname) {
|
||||
print $out @cache,"1;\n# end of $last_package\::$subname\n";
|
||||
close($out);
|
||||
}
|
||||
close($in);
|
||||
|
||||
if (!$keep){ # don't keep any obsolete *.al files in the directory
|
||||
my(%outfiles);
|
||||
# @outfiles{@outfiles} = @outfiles;
|
||||
# perl downcases all filenames on VMS (which upcases all filenames) so
|
||||
# we'd better downcase the sub name list too, or subs with upper case
|
||||
# letters in them will get their .al files deleted right after they're
|
||||
# created. (The mixed case sub name won't match the all-lowercase
|
||||
# filename, and so be cleaned up as a scrap file)
|
||||
if ($Is_VMS or $Is83) {
|
||||
%outfiles = map {lc($_) => lc($_) } @outfiles;
|
||||
} else {
|
||||
@outfiles{@outfiles} = @outfiles;
|
||||
}
|
||||
my(%outdirs,@outdirs);
|
||||
for (@outfiles) {
|
||||
$outdirs{File::Basename::dirname($_)}||=1;
|
||||
}
|
||||
for my $dir (keys %outdirs) {
|
||||
opendir(my $outdir,$dir);
|
||||
foreach (sort readdir($outdir)){
|
||||
next unless /\.al\z/;
|
||||
my($file) = catfile($dir, $_);
|
||||
$file = lc $file if $Is83 or $Is_VMS;
|
||||
next if $outfiles{$file};
|
||||
print " deleting $file\n" if ($Verbose>=2);
|
||||
my($deleted,$thistime); # catch all versions on VMS
|
||||
do { $deleted += ($thistime = unlink $file) } while ($thistime);
|
||||
carp ("Unable to delete $file: $!") unless $deleted;
|
||||
}
|
||||
closedir($outdir);
|
||||
}
|
||||
}
|
||||
|
||||
open(my $ts,">$al_idx_file") or
|
||||
carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
|
||||
print $ts "# Index created by AutoSplit for $filename\n";
|
||||
print $ts "# (file acts as timestamp)\n";
|
||||
$last_package = '';
|
||||
for my $fqs (@subnames) {
|
||||
my($subname) = $fqs;
|
||||
$subname =~ s/.*:://;
|
||||
print $ts "package $package{$fqs};\n"
|
||||
unless $last_package eq $package{$fqs};
|
||||
print $ts "sub $subname $proto{$fqs};\n";
|
||||
$last_package = $package{$fqs};
|
||||
}
|
||||
print $ts "1;\n";
|
||||
close($ts);
|
||||
|
||||
_check_unique($filename, $Maxlen, 1, @outfiles);
|
||||
|
||||
@outfiles;
|
||||
}
|
||||
|
||||
sub _modpname ($) {
|
||||
my($package) = @_;
|
||||
my $modpname = $package;
|
||||
if ($^O eq 'MSWin32') {
|
||||
$modpname =~ s#::#\\#g;
|
||||
} else {
|
||||
my @modpnames = ();
|
||||
while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
|
||||
push @modpnames, $1;
|
||||
$modpname = $2;
|
||||
}
|
||||
$modpname = catfile(@modpnames, $modpname);
|
||||
}
|
||||
if ($Is_VMS) {
|
||||
$modpname = VMS::Filespec::unixify($modpname); # may have dirs
|
||||
}
|
||||
$modpname;
|
||||
}
|
||||
|
||||
sub _check_unique {
|
||||
my($filename, $maxlen, $warn, @outfiles) = @_;
|
||||
my(%notuniq) = ();
|
||||
my(%shorts) = ();
|
||||
my(@toolong) = grep(
|
||||
length(File::Basename::basename($_))
|
||||
> $maxlen,
|
||||
@outfiles
|
||||
);
|
||||
|
||||
foreach (@toolong){
|
||||
my($dir) = File::Basename::dirname($_);
|
||||
my($file) = File::Basename::basename($_);
|
||||
my($trunc) = substr($file,0,$maxlen);
|
||||
$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
|
||||
$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
|
||||
"$shorts{$dir}{$trunc}, $file" : $file;
|
||||
}
|
||||
if (%notuniq && $warn){
|
||||
print "$filename: some names are not unique when " .
|
||||
"truncated to $maxlen characters:\n";
|
||||
foreach my $dir (sort keys %notuniq){
|
||||
print " directory $dir:\n";
|
||||
foreach my $trunc (sort keys %{$notuniq{$dir}}) {
|
||||
print " $shorts{$dir}{$trunc} truncate to $trunc\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
# test functions so AutoSplit.pm can be applied to itself:
|
||||
sub test1 ($) { "test 1\n"; }
|
||||
sub test2 ($$) { "test 2\n"; }
|
||||
sub test3 ($$$) { "test 3\n"; }
|
||||
sub testtesttesttest4_1 { "test 4\n"; }
|
||||
sub testtesttesttest4_2 { "duplicate test 4\n"; }
|
||||
sub Just::Another::test5 { "another test 5\n"; }
|
||||
sub test6 { return join ":", __FILE__,__LINE__; }
|
||||
package Yet::Another::AutoSplit;
|
||||
sub testtesttesttest4_1 ($) { "another test 4\n"; }
|
||||
sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
|
||||
package Yet::More::Attributes;
|
||||
sub test_a1 ($) : locked :locked { 1; }
|
||||
sub test_a2 : locked { 1; }
|
||||
|
|
@ -0,0 +1,457 @@
|
|||
package B::Debug;
|
||||
|
||||
our $VERSION = '1.23';
|
||||
|
||||
use strict;
|
||||
require 5.006;
|
||||
use B qw(peekop class walkoptree walkoptree_exec
|
||||
main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
|
||||
use Config;
|
||||
my (@optype, @specialsv_name);
|
||||
require B;
|
||||
if ($] < 5.009) {
|
||||
require B::Asmdata;
|
||||
B::Asmdata->import (qw(@optype @specialsv_name));
|
||||
} else {
|
||||
B->import (qw(@optype @specialsv_name));
|
||||
}
|
||||
|
||||
if ($] < 5.006002) {
|
||||
eval q|sub B::GV::SAFENAME {
|
||||
my $name = (shift())->NAME;
|
||||
# The regex below corresponds to the isCONTROLVAR macro from toke.c
|
||||
$name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e;
|
||||
return $name;
|
||||
}|;
|
||||
}
|
||||
|
||||
my ($have_B_Flags, $have_B_Flags_extra);
|
||||
if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
|
||||
eval { require B::Flags and $have_B_Flags++ };
|
||||
$have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03';
|
||||
}
|
||||
my %done_gv;
|
||||
|
||||
sub _printop {
|
||||
my $op = shift;
|
||||
my $addr = ${$op} ? $op->ppaddr : '';
|
||||
$addr =~ s/^PL_ppaddr// if $addr;
|
||||
if (${$op}) {
|
||||
return sprintf "0x%08x %6s %s", ${$op}, class($op), $addr;
|
||||
} else {
|
||||
return sprintf "0x%x %6s %s", ${$op}, '', $addr;
|
||||
}
|
||||
}
|
||||
|
||||
sub B::OP::debug {
|
||||
my ($op) = @_;
|
||||
printf <<'EOT', class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
|
||||
%s (0x%lx)
|
||||
op_ppaddr %s
|
||||
op_next %s
|
||||
op_sibling %s
|
||||
op_targ %d
|
||||
op_type %d %s
|
||||
EOT
|
||||
if ($] > 5.009) {
|
||||
printf <<'EOT', $op->opt;
|
||||
op_opt %d
|
||||
EOT
|
||||
} else {
|
||||
printf <<'EOT', $op->seq;
|
||||
op_seq %d
|
||||
EOT
|
||||
}
|
||||
if ($have_B_Flags) {
|
||||
printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
|
||||
op_flags %d %s
|
||||
op_private %d %s
|
||||
EOT
|
||||
} else {
|
||||
printf <<'EOT', $op->flags, $op->private;
|
||||
op_flags %d
|
||||
op_private %d
|
||||
EOT
|
||||
}
|
||||
}
|
||||
|
||||
sub B::UNOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::OP::debug();
|
||||
printf "\top_first\t%s\n", _printop($op->first);
|
||||
}
|
||||
|
||||
sub B::BINOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::UNOP::debug();
|
||||
printf "\top_last \t%s\n", _printop($op->last);
|
||||
}
|
||||
|
||||
sub B::LOOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::BINOP::debug();
|
||||
printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
|
||||
op_redoop %s
|
||||
op_nextop %s
|
||||
op_lastop %s
|
||||
EOT
|
||||
}
|
||||
|
||||
sub B::LOGOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::UNOP::debug();
|
||||
printf "\top_other\t%s\n", _printop($op->other);
|
||||
}
|
||||
|
||||
sub B::LISTOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::BINOP::debug();
|
||||
printf "\top_children\t%d\n", $op->children;
|
||||
}
|
||||
|
||||
sub B::PMOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::LISTOP::debug();
|
||||
printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
|
||||
printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
|
||||
printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
|
||||
if ($Config{'useithreads'}) {
|
||||
printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
|
||||
printf "\top_pmoffset\t%d\n", $op->pmoffset;
|
||||
} else {
|
||||
printf "\top_pmstash\t%s\n", cstring($op->pmstash);
|
||||
}
|
||||
printf "\top_precomp\t%s\n", cstring($op->precomp);
|
||||
printf "\top_pmflags\t0x%x\n", $op->pmflags;
|
||||
printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
|
||||
printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
|
||||
printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
|
||||
$op->pmreplroot->debug if $] < 5.008;
|
||||
}
|
||||
|
||||
sub B::COP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::OP::debug();
|
||||
my $warnings = ref $op->warnings ? ${$op->warnings} : 0;
|
||||
printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings;
|
||||
cop_label "%s"
|
||||
cop_stashpv "%s"
|
||||
cop_file "%s"
|
||||
cop_seq %d
|
||||
cop_arybase %d
|
||||
cop_line %d
|
||||
cop_warnings 0x%x
|
||||
EOT
|
||||
if ($] > 5.008 and $] < 5.011) {
|
||||
my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
|
||||
printf(" cop_io %s\n", cstring($cop_io));
|
||||
}
|
||||
}
|
||||
|
||||
sub B::SVOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::OP::debug();
|
||||
printf "\top_sv\t\t0x%x\n", ${$op->sv};
|
||||
$op->sv->debug;
|
||||
}
|
||||
|
||||
sub B::METHOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::OP::debug();
|
||||
if (${$op->first}) {
|
||||
printf "\top_first\t0x%x\n", ${$op->first};
|
||||
$op->first->debug;
|
||||
} else {
|
||||
printf "\top_meth_sv\t0x%x\n", ${$op->meth_sv};
|
||||
$op->meth_sv->debug;
|
||||
}
|
||||
}
|
||||
|
||||
sub B::PVOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::OP::debug();
|
||||
printf "\top_pv\t\t%s\n", cstring($op->pv);
|
||||
}
|
||||
|
||||
sub B::PADOP::debug {
|
||||
my ($op) = @_;
|
||||
$op->B::OP::debug();
|
||||
printf "\top_padix\t%ld\n", $op->padix;
|
||||
}
|
||||
|
||||
sub B::NULL::debug {
|
||||
my ($sv) = @_;
|
||||
if ($$sv == ${sv_undef()}) {
|
||||
print "&sv_undef\n";
|
||||
} else {
|
||||
printf "NULL (0x%x)\n", $$sv;
|
||||
}
|
||||
}
|
||||
|
||||
sub B::SV::debug {
|
||||
my ($sv) = @_;
|
||||
if (!$$sv) {
|
||||
print class($sv), " = NULL\n";
|
||||
return;
|
||||
}
|
||||
printf <<'EOT', class($sv), $$sv, $sv->REFCNT;
|
||||
%s (0x%x)
|
||||
REFCNT %d
|
||||
EOT
|
||||
printf "\tFLAGS\t\t0x%x", $sv->FLAGS;
|
||||
if ($have_B_Flags) {
|
||||
printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
|
||||
sub B::RV::debug {
|
||||
my ($rv) = @_;
|
||||
B::SV::debug($rv);
|
||||
printf <<'EOT', ${$rv->RV};
|
||||
RV 0x%x
|
||||
EOT
|
||||
$rv->RV->debug;
|
||||
}
|
||||
|
||||
sub B::PV::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::SV::debug();
|
||||
my $pv = $sv->PV();
|
||||
printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN;
|
||||
xpv_pv %s
|
||||
xpv_cur %d
|
||||
xpv_len %d
|
||||
EOT
|
||||
}
|
||||
|
||||
sub B::IV::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::SV::debug();
|
||||
printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
|
||||
}
|
||||
|
||||
sub B::NV::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::IV::debug();
|
||||
printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
|
||||
}
|
||||
|
||||
sub B::PVIV::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::PV::debug();
|
||||
printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
|
||||
}
|
||||
|
||||
sub B::PVNV::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::PVIV::debug();
|
||||
printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
|
||||
}
|
||||
|
||||
sub B::PVLV::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::PVNV::debug();
|
||||
printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
|
||||
printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
|
||||
printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
|
||||
}
|
||||
|
||||
sub B::BM::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::PVNV::debug();
|
||||
printf "\txbm_useful\t%d\n", $sv->USEFUL;
|
||||
printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
|
||||
printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
|
||||
}
|
||||
|
||||
sub B::CV::debug {
|
||||
my ($sv) = @_;
|
||||
$sv->B::PVNV::debug();
|
||||
my ($stash) = $sv->STASH;
|
||||
my ($start) = $sv->START;
|
||||
my ($root) = $sv->ROOT;
|
||||
my ($padlist) = $sv->PADLIST;
|
||||
my ($file) = $sv->FILE;
|
||||
my ($gv) = $sv->GV;
|
||||
printf <<'EOT', $$stash, $$start, $$root;
|
||||
STASH 0x%x
|
||||
START 0x%x
|
||||
ROOT 0x%x
|
||||
EOT
|
||||
if ( $]>5.017 && ($sv->FLAGS & 0x40000)) { #lexsub
|
||||
printf("\tNAME\t%%s\n", $sv->NAME);
|
||||
} else {
|
||||
printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME);
|
||||
}
|
||||
printf <<'EOT', $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
|
||||
FILE %s
|
||||
DEPTH %d
|
||||
PADLIST 0x%x
|
||||
OUTSIDE 0x%x
|
||||
EOT
|
||||
printf("\tOUTSIDE_SEQ\t%d\n", $sv->OUTSIDE_SEQ) if $] > 5.007;
|
||||
if ($have_B_Flags) {
|
||||
my $SVt_PVCV = $] < 5.010 ? 12 : 13;
|
||||
printf("\tCvFLAGS\t0x%x\t%s\n", $sv->CvFLAGS,
|
||||
$have_B_Flags_extra ? $sv->flagspv($SVt_PVCV) : $sv->flagspv);
|
||||
} else {
|
||||
printf("\tCvFLAGS\t0x%x\n", $sv->CvFLAGS);
|
||||
}
|
||||
$start->debug if $start;
|
||||
$root->debug if $root;
|
||||
$gv->debug if $gv;
|
||||
$padlist->debug if $padlist;
|
||||
}
|
||||
|
||||
sub B::AV::debug {
|
||||
my ($av) = @_;
|
||||
$av->B::SV::debug;
|
||||
_array_debug($av);
|
||||
}
|
||||
|
||||
sub _array_debug {
|
||||
my ($av) = @_;
|
||||
# tied arrays may leave out FETCHSIZE
|
||||
my (@array) = eval { $av->ARRAY; };
|
||||
print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
|
||||
my $fill = eval { scalar(@array) };
|
||||
if ($Config{'useithreads'} && class($av) ne 'PADLIST') {
|
||||
printf <<'EOT', $fill, $av->MAX, $av->OFF;
|
||||
FILL %d
|
||||
MAX %d
|
||||
OFF %d
|
||||
EOT
|
||||
} else {
|
||||
printf <<'EOT', $fill, $av->MAX;
|
||||
FILL %d
|
||||
MAX %d
|
||||
EOT
|
||||
}
|
||||
if ($] < 5.009) {
|
||||
if ($have_B_Flags) {
|
||||
printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
|
||||
$have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
|
||||
} else {
|
||||
printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub B::GV::debug {
|
||||
my ($gv) = @_;
|
||||
if ($done_gv{$$gv}++) {
|
||||
printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
|
||||
return;
|
||||
}
|
||||
my $sv = $gv->SV;
|
||||
my $av = $gv->AV;
|
||||
my $cv = $gv->CV;
|
||||
$gv->B::SV::debug;
|
||||
printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
|
||||
NAME %s
|
||||
STASH %s (0x%x)
|
||||
SV 0x%x
|
||||
GvREFCNT %d
|
||||
FORM 0x%x
|
||||
AV 0x%x
|
||||
HV 0x%x
|
||||
EGV 0x%x
|
||||
CV 0x%x
|
||||
CVGEN %d
|
||||
LINE %d
|
||||
FILE %s
|
||||
EOT
|
||||
if ($have_B_Flags) {
|
||||
my $SVt_PVGV = $] < 5.010 ? 13 : 9;
|
||||
printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
|
||||
$have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
|
||||
} else {
|
||||
printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
|
||||
}
|
||||
$sv->debug if $sv;
|
||||
$av->debug if $av;
|
||||
$cv->debug if $cv;
|
||||
}
|
||||
|
||||
sub B::SPECIAL::debug {
|
||||
my $sv = shift;
|
||||
my $i = ref $sv ? $$sv : 0;
|
||||
print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
|
||||
}
|
||||
|
||||
sub B::PADLIST::debug {
|
||||
my ($padlist) = @_;
|
||||
printf <<'EOT', class($padlist), $$padlist, $padlist->REFCNT;
|
||||
%s (0x%x)
|
||||
REFCNT %d
|
||||
EOT
|
||||
_array_debug($padlist);
|
||||
}
|
||||
|
||||
sub compile {
|
||||
my $order = shift;
|
||||
B::clearsym();
|
||||
$DB::single = 1 if defined &DB::DB;
|
||||
if ($order && $order eq "exec") {
|
||||
return sub { walkoptree_exec(main_start, "debug") }
|
||||
} else {
|
||||
return sub { walkoptree(main_root, "debug") }
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
B::Debug - Walk Perl syntax tree, printing debug info about ops
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
perl -MO=Debug foo.pl
|
||||
perl -MO=Debug,-exec foo.pl
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
With option -exec, walks tree in execute order,
|
||||
otherwise in basic order.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
|
||||
Reini Urban C<rurban@cpan.org>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (c) 1996, 1997 Malcolm Beattie
|
||||
Copyright (c) 2008, 2010, 2013, 2014 Reini Urban
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of either:
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
|
||||
b) the "Artistic License" which comes with this kit.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
|
||||
the GNU General Public License or the Artistic License for more details.
|
||||
|
||||
You should have received a copy of the Artistic License with this kit,
|
||||
in the file named "Artistic". If not, you can get one from the Perl
|
||||
distribution. You should also have received a copy of the GNU General
|
||||
Public License, in the file named "Copying". If not, you can get one
|
||||
from the Perl distribution or else write to the Free Software Foundation,
|
||||
Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
|
||||
=cut
|
||||
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,836 @@
|
|||
# -*- buffer-read-only: t -*-
|
||||
#
|
||||
# lib/B/Op_private.pm
|
||||
#
|
||||
# Copyright (C) 2014 by Larry Wall and others
|
||||
#
|
||||
# You may distribute under the terms of either the GNU General Public
|
||||
# License or the Artistic License, as specified in the README file.
|
||||
#
|
||||
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
|
||||
# This file is built by regen/opcode.pl from data in
|
||||
# regen/op_private and pod embedded in regen/opcode.pl.
|
||||
# Any changes made here will be lost!
|
||||
|
||||
=head1 NAME
|
||||
|
||||
B::Op_private - OP op_private flag definitions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use B::Op_private;
|
||||
|
||||
# flag details for bit 7 of OP_AELEM's op_private:
|
||||
my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO
|
||||
my $value = $B::Op_private::defines{$name}; # 128
|
||||
my $label = $B::Op_private::labels{$name}; # LVINTRO
|
||||
|
||||
# the bit field at bits 5..6 of OP_AELEM's op_private:
|
||||
my $bf = $B::Op_private::bits{aelem}{6};
|
||||
my $mask = $bf->{bitmask}; # etc
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides four global hashes:
|
||||
|
||||
%B::Op_private::bits
|
||||
%B::Op_private::defines
|
||||
%B::Op_private::labels
|
||||
%B::Op_private::ops_using
|
||||
|
||||
which contain information about the per-op meanings of the bits in the
|
||||
op_private field.
|
||||
|
||||
=head2 C<%bits>
|
||||
|
||||
This is indexed by op name and then bit number (0..7). For single bit flags,
|
||||
it returns the name of the define (if any) for that bit:
|
||||
|
||||
$B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO';
|
||||
|
||||
For bit fields, it returns a hash ref containing details about the field.
|
||||
The same reference will be returned for all bit positions that make
|
||||
up the bit field; so for example these both return the same hash ref:
|
||||
|
||||
$bitfield = $B::Op_private::bits{aelem}{5};
|
||||
$bitfield = $B::Op_private::bits{aelem}{6};
|
||||
|
||||
The general format of this hash ref is
|
||||
|
||||
{
|
||||
# The bit range and mask; these are always present.
|
||||
bitmin => 5,
|
||||
bitmax => 6,
|
||||
bitmask => 0x60,
|
||||
|
||||
# (The remaining keys are optional)
|
||||
|
||||
# The names of any defines that were requested:
|
||||
mask_def => 'OPpFOO_MASK',
|
||||
baseshift_def => 'OPpFOO_SHIFT',
|
||||
bitcount_def => 'OPpFOO_BITS',
|
||||
|
||||
# If present, Concise etc will display the value with a 'FOO='
|
||||
# prefix. If it equals '-', then Concise will treat the bit
|
||||
# field as raw bits and not try to interpret it.
|
||||
label => 'FOO',
|
||||
|
||||
# If present, specifies the names of some defines and the
|
||||
# display labels that are used to assign meaning to particu-
|
||||
# lar integer values within the bit field; e.g. 3 is dis-
|
||||
# played as 'C'.
|
||||
enum => [ qw(
|
||||
1 OPpFOO_A A
|
||||
2 OPpFOO_B B
|
||||
3 OPpFOO_C C
|
||||
)],
|
||||
|
||||
};
|
||||
|
||||
|
||||
=head2 C<%defines>
|
||||
|
||||
This gives the value of every C<OPp> define, e.g.
|
||||
|
||||
$B::Op_private::defines{OPpLVAL_INTRO} == 128;
|
||||
|
||||
=head2 C<%labels>
|
||||
|
||||
This gives the short display label for each define, as used by C<B::Concise>
|
||||
and C<perl -Dx>, e.g.
|
||||
|
||||
$B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO';
|
||||
|
||||
If the label equals '-', then Concise will treat the bit as a raw bit and
|
||||
not try to display it symbolically.
|
||||
|
||||
=head2 C<%ops_using>
|
||||
|
||||
For each define, this gives a reference to an array of op names that use
|
||||
the flag.
|
||||
|
||||
@ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} };
|
||||
|
||||
=cut
|
||||
|
||||
package B::Op_private;
|
||||
|
||||
our %bits;
|
||||
|
||||
|
||||
our $VERSION = "5.022000";
|
||||
|
||||
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
|
||||
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
|
||||
$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv);
|
||||
$bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop);
|
||||
$bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite);
|
||||
$bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
|
||||
$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
|
||||
$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
|
||||
$bits{$_}{1} = 'OPpGREP_LEX' for qw(grepstart grepwhile mapstart mapwhile);
|
||||
$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv);
|
||||
$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate);
|
||||
$bits{$_}{2} = 'OPpITER_REVERSED' for qw(enteriter iter);
|
||||
$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop);
|
||||
$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref);
|
||||
$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv);
|
||||
$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
|
||||
$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
|
||||
$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rkeys rv2av rv2gv rv2hv substr vec);
|
||||
$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv);
|
||||
$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray);
|
||||
$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open);
|
||||
$bits{$_}{4} = 'OPpOPEN_IN_RAW' for qw(backtick open);
|
||||
$bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open);
|
||||
$bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open);
|
||||
$bits{$_}{6} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv split);
|
||||
$bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark refassign);
|
||||
$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
|
||||
$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
|
||||
$bits{$_}{6} = 'OPpRUNTIME' for qw(match pushre qr subst substcont);
|
||||
$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
|
||||
$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push pushre qr rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid);
|
||||
$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
|
||||
$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
|
||||
$bits{$_}{0} = 'OPpTRANS_FROM_UTF' for qw(trans transr);
|
||||
$bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr);
|
||||
$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr);
|
||||
$bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr);
|
||||
$bits{$_}{1} = 'OPpTRANS_TO_UTF' for qw(trans transr);
|
||||
$bits{$_}{5} = 'OPpTRUEBOOL' for qw(padhv rv2hv);
|
||||
|
||||
my @bf = (
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG1_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 0,
|
||||
bitmask => 1,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG2_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 1,
|
||||
bitmask => 3,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG3_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 2,
|
||||
bitmask => 7,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpARG4_MASK',
|
||||
bitmin => 0,
|
||||
bitmax => 3,
|
||||
bitmask => 15,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
mask_def => 'OPpPADRANGE_COUNTMASK',
|
||||
bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
|
||||
bitmin => 0,
|
||||
bitmax => 6,
|
||||
bitmask => 127,
|
||||
},
|
||||
{
|
||||
label => '-',
|
||||
bitmin => 0,
|
||||
bitmax => 7,
|
||||
bitmask => 255,
|
||||
},
|
||||
{
|
||||
mask_def => 'OPpDEREF',
|
||||
bitmin => 4,
|
||||
bitmax => 5,
|
||||
bitmask => 48,
|
||||
enum => [
|
||||
1, 'OPpDEREF_AV', 'DREFAV',
|
||||
2, 'OPpDEREF_HV', 'DREFHV',
|
||||
3, 'OPpDEREF_SV', 'DREFSV',
|
||||
],
|
||||
},
|
||||
{
|
||||
mask_def => 'OPpLVREF_TYPE',
|
||||
bitmin => 4,
|
||||
bitmax => 5,
|
||||
bitmask => 48,
|
||||
enum => [
|
||||
0, 'OPpLVREF_SV', 'SV',
|
||||
1, 'OPpLVREF_AV', 'AV',
|
||||
2, 'OPpLVREF_HV', 'HV',
|
||||
3, 'OPpLVREF_CV', 'CV',
|
||||
],
|
||||
},
|
||||
);
|
||||
|
||||
@{$bits{aassign}}{6,1,0} = ('OPpASSIGN_COMMON', $bf[1], $bf[1]);
|
||||
$bits{abs}{0} = $bf[0];
|
||||
@{$bits{accept}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{aeach}{0} = $bf[0];
|
||||
@{$bits{aelem}}{5,4,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
|
||||
@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
|
||||
@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
|
||||
$bits{akeys}{0} = $bf[0];
|
||||
$bits{alarm}{0} = $bf[0];
|
||||
$bits{and}{0} = $bf[0];
|
||||
$bits{andassign}{0} = $bf[0];
|
||||
$bits{anonconst}{0} = $bf[0];
|
||||
@{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{av2arylen}{0} = $bf[0];
|
||||
$bits{avalues}{0} = $bf[0];
|
||||
$bits{backtick}{0} = $bf[0];
|
||||
@{$bits{bind}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{binmode}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{bit_and}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{bit_or}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{bit_xor}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{bless}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{caller}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{chdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{chmod}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{chomp}{0} = $bf[0];
|
||||
$bits{chop}{0} = $bf[0];
|
||||
@{$bits{chown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{chr}{0} = $bf[0];
|
||||
$bits{chroot}{0} = $bf[0];
|
||||
@{$bits{close}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{closedir}{0} = $bf[0];
|
||||
$bits{complement}{0} = $bf[0];
|
||||
@{$bits{concat}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{cond_expr}{0} = $bf[0];
|
||||
@{$bits{connect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER');
|
||||
@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1');
|
||||
$bits{cos}{0} = $bf[0];
|
||||
@{$bits{crypt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{dbmclose}{0} = $bf[0];
|
||||
@{$bits{dbmopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{defined}{0} = $bf[0];
|
||||
@{$bits{delete}}{6,0} = ('OPpSLICE', $bf[0]);
|
||||
@{$bits{die}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{divide}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{dofile}{0} = $bf[0];
|
||||
$bits{dor}{0} = $bf[0];
|
||||
$bits{dorassign}{0} = $bf[0];
|
||||
$bits{dump}{0} = $bf[0];
|
||||
$bits{each}{0} = $bf[0];
|
||||
@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
|
||||
$bits{entergiven}{0} = $bf[0];
|
||||
$bits{enteriter}{3} = 'OPpITER_DEF';
|
||||
@{$bits{entersub}}{5,4,0} = ($bf[6], $bf[6], 'OPpENTERSUB_INARGS');
|
||||
$bits{entertry}{0} = $bf[0];
|
||||
$bits{enterwhen}{0} = $bf[0];
|
||||
@{$bits{enterwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{eof}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{eq}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{exec}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]);
|
||||
@{$bits{exit}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{exp}{0} = $bf[0];
|
||||
$bits{fc}{0} = $bf[0];
|
||||
@{$bits{fcntl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{fileno}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{flip}{0} = $bf[0];
|
||||
@{$bits{flock}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{flop}{0} = $bf[0];
|
||||
@{$bits{formline}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{ftatime}{0} = $bf[0];
|
||||
$bits{ftbinary}{0} = $bf[0];
|
||||
$bits{ftblk}{0} = $bf[0];
|
||||
$bits{ftchr}{0} = $bf[0];
|
||||
$bits{ftctime}{0} = $bf[0];
|
||||
$bits{ftdir}{0} = $bf[0];
|
||||
$bits{fteexec}{0} = $bf[0];
|
||||
$bits{fteowned}{0} = $bf[0];
|
||||
$bits{fteread}{0} = $bf[0];
|
||||
$bits{ftewrite}{0} = $bf[0];
|
||||
$bits{ftfile}{0} = $bf[0];
|
||||
$bits{ftis}{0} = $bf[0];
|
||||
$bits{ftlink}{0} = $bf[0];
|
||||
$bits{ftmtime}{0} = $bf[0];
|
||||
$bits{ftpipe}{0} = $bf[0];
|
||||
$bits{ftrexec}{0} = $bf[0];
|
||||
$bits{ftrowned}{0} = $bf[0];
|
||||
$bits{ftrread}{0} = $bf[0];
|
||||
$bits{ftrwrite}{0} = $bf[0];
|
||||
$bits{ftsgid}{0} = $bf[0];
|
||||
$bits{ftsize}{0} = $bf[0];
|
||||
$bits{ftsock}{0} = $bf[0];
|
||||
$bits{ftsuid}{0} = $bf[0];
|
||||
$bits{ftsvtx}{0} = $bf[0];
|
||||
$bits{fttext}{0} = $bf[0];
|
||||
$bits{fttty}{0} = $bf[0];
|
||||
$bits{ftzero}{0} = $bf[0];
|
||||
@{$bits{ge}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{getc}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{getpeername}{0} = $bf[0];
|
||||
@{$bits{getpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{getpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{getsockname}{0} = $bf[0];
|
||||
$bits{ggrgid}{0} = $bf[0];
|
||||
$bits{ggrnam}{0} = $bf[0];
|
||||
@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{ghbyname}{0} = $bf[0];
|
||||
@{$bits{glob}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{gmtime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{gnbyname}{0} = $bf[0];
|
||||
$bits{goto}{0} = $bf[0];
|
||||
$bits{gpbyname}{0} = $bf[0];
|
||||
@{$bits{gpbynumber}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{gpwnam}{0} = $bf[0];
|
||||
$bits{gpwuid}{0} = $bf[0];
|
||||
$bits{grepstart}{0} = $bf[0];
|
||||
$bits{grepwhile}{0} = $bf[0];
|
||||
@{$bits{gsbyname}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{gsbyport}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{gsockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{gv}{5} = 'OPpEARLY_CV';
|
||||
@{$bits{helem}}{5,4,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
|
||||
$bits{hex}{0} = $bf[0];
|
||||
@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_le}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{i_negate}{0} = $bf[0];
|
||||
$bits{i_postdec}{0} = $bf[0];
|
||||
$bits{i_postinc}{0} = $bf[0];
|
||||
$bits{i_predec}{0} = $bf[0];
|
||||
$bits{i_preinc}{0} = $bf[0];
|
||||
@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{index}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{int}{0} = $bf[0];
|
||||
@{$bits{ioctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{join}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{keys}{0} = $bf[0];
|
||||
@{$bits{kill}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{last}{0} = $bf[0];
|
||||
$bits{lc}{0} = $bf[0];
|
||||
$bits{lcfirst}{0} = $bf[0];
|
||||
@{$bits{le}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{leaveeval}{0} = $bf[0];
|
||||
$bits{leavegiven}{0} = $bf[0];
|
||||
@{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{leavesub}{0} = $bf[0];
|
||||
$bits{leavesublv}{0} = $bf[0];
|
||||
$bits{leavewhen}{0} = $bf[0];
|
||||
$bits{leavewrite}{0} = $bf[0];
|
||||
@{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{length}{0} = $bf[0];
|
||||
@{$bits{link}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{list}{6} = 'OPpLIST_GUESSED';
|
||||
@{$bits{listen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{localtime}{0} = $bf[0];
|
||||
$bits{lock}{0} = $bf[0];
|
||||
$bits{log}{0} = $bf[0];
|
||||
@{$bits{lslice}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{lstat}{0} = $bf[0];
|
||||
@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{lvavref}{0} = $bf[0];
|
||||
@{$bits{lvref}}{5,4,0} = ($bf[7], $bf[7], $bf[0]);
|
||||
$bits{mapstart}{0} = $bf[0];
|
||||
$bits{mapwhile}{0} = $bf[0];
|
||||
$bits{method}{0} = $bf[0];
|
||||
$bits{method_named}{0} = $bf[0];
|
||||
$bits{method_redir}{0} = $bf[0];
|
||||
$bits{method_redir_super}{0} = $bf[0];
|
||||
$bits{method_super}{0} = $bf[0];
|
||||
@{$bits{mkdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{msgctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{msgget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{msgrcv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{msgsnd}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{multideref}}{5,4,0} = ('OPpMULTIDEREF_DELETE', 'OPpMULTIDEREF_EXISTS', $bf[0]);
|
||||
@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{nbit_and}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{nbit_or}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{nbit_xor}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{ncomplement}{0} = $bf[0];
|
||||
@{$bits{ne}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{negate}{0} = $bf[0];
|
||||
$bits{next}{0} = $bf[0];
|
||||
$bits{not}{0} = $bf[0];
|
||||
$bits{oct}{0} = $bf[0];
|
||||
$bits{once}{0} = $bf[0];
|
||||
@{$bits{open}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{open_dir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{or}{0} = $bf[0];
|
||||
$bits{orassign}{0} = $bf[0];
|
||||
$bits{ord}{0} = $bf[0];
|
||||
@{$bits{pack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4]);
|
||||
@{$bits{padsv}}{5,4} = ($bf[6], $bf[6]);
|
||||
@{$bits{pipe_op}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{pop}{0} = $bf[0];
|
||||
$bits{pos}{0} = $bf[0];
|
||||
$bits{postdec}{0} = $bf[0];
|
||||
$bits{postinc}{0} = $bf[0];
|
||||
@{$bits{pow}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{predec}{0} = $bf[0];
|
||||
$bits{preinc}{0} = $bf[0];
|
||||
$bits{prototype}{0} = $bf[0];
|
||||
@{$bits{push}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{quotemeta}{0} = $bf[0];
|
||||
@{$bits{rand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{range}{0} = $bf[0];
|
||||
$bits{reach}{0} = $bf[0];
|
||||
@{$bits{read}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{readdir}{0} = $bf[0];
|
||||
$bits{readline}{0} = $bf[0];
|
||||
$bits{readlink}{0} = $bf[0];
|
||||
@{$bits{recv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{redo}{0} = $bf[0];
|
||||
$bits{ref}{0} = $bf[0];
|
||||
@{$bits{refassign}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
|
||||
$bits{refgen}{0} = $bf[0];
|
||||
$bits{regcmaybe}{0} = $bf[0];
|
||||
$bits{regcomp}{0} = $bf[0];
|
||||
$bits{regcreset}{0} = $bf[0];
|
||||
@{$bits{rename}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]);
|
||||
$bits{require}{0} = $bf[0];
|
||||
@{$bits{reset}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]);
|
||||
$bits{rewinddir}{0} = $bf[0];
|
||||
@{$bits{right_shift}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{rindex}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{rkeys}{0} = $bf[0];
|
||||
$bits{rmdir}{0} = $bf[0];
|
||||
$bits{rv2av}{0} = $bf[0];
|
||||
@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
|
||||
@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[6], $bf[6], 'OPpDONT_INIT_GV', $bf[0]);
|
||||
$bits{rv2hv}{0} = $bf[0];
|
||||
@{$bits{rv2sv}}{5,4,0} = ($bf[6], $bf[6], $bf[0]);
|
||||
$bits{rvalues}{0} = $bf[0];
|
||||
@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
|
||||
@{$bits{sbit_and}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sbit_or}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sbit_xor}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{scalar}{0} = $bf[0];
|
||||
$bits{schomp}{0} = $bf[0];
|
||||
$bits{schop}{0} = $bf[0];
|
||||
@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{scomplement}{0} = $bf[0];
|
||||
@{$bits{seek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{seekdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{select}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{semctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{semget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{semop}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{send}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{seq}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{setpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{setpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{sge}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{shift}{0} = $bf[0];
|
||||
@{$bits{shmctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{shmget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{shmread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{shmwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{shostent}{0} = $bf[0];
|
||||
@{$bits{shutdown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{sin}{0} = $bf[0];
|
||||
@{$bits{sle}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sleep}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{slt}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{sne}}{1,0} = ($bf[1], $bf[1]);
|
||||
$bits{snetent}{0} = $bf[0];
|
||||
@{$bits{socket}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{sockpair}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{sort}}{6,5,4,3,2,1,0} = ('OPpSORT_STABLE', 'OPpSORT_QSORT', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
|
||||
@{$bits{splice}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{split}{7} = 'OPpSPLIT_IMPLIM';
|
||||
@{$bits{sprintf}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{sprotoent}{0} = $bf[0];
|
||||
$bits{sqrt}{0} = $bf[0];
|
||||
@{$bits{srand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{srefgen}{0} = $bf[0];
|
||||
@{$bits{sselect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{sservent}{0} = $bf[0];
|
||||
@{$bits{ssockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{stat}{0} = $bf[0];
|
||||
@{$bits{stringify}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{study}{0} = $bf[0];
|
||||
$bits{substcont}{0} = $bf[0];
|
||||
@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[2], $bf[2], $bf[2]);
|
||||
@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{symlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{syscall}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{sysopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{sysread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{sysseek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{system}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{syswrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{tell}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{telldir}{0} = $bf[0];
|
||||
@{$bits{tie}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{tied}{0} = $bf[0];
|
||||
@{$bits{truncate}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{uc}{0} = $bf[0];
|
||||
$bits{ucfirst}{0} = $bf[0];
|
||||
@{$bits{umask}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{undef}{0} = $bf[0];
|
||||
@{$bits{unlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{unpack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{unshift}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{untie}{0} = $bf[0];
|
||||
@{$bits{utime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
$bits{values}{0} = $bf[0];
|
||||
@{$bits{vec}}{1,0} = ($bf[1], $bf[1]);
|
||||
@{$bits{waitpid}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{warn}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
|
||||
@{$bits{xor}}{1,0} = ($bf[1], $bf[1]);
|
||||
|
||||
|
||||
our %defines = (
|
||||
OPpALLOW_FAKE => 64,
|
||||
OPpARG1_MASK => 1,
|
||||
OPpARG2_MASK => 3,
|
||||
OPpARG3_MASK => 7,
|
||||
OPpARG4_MASK => 15,
|
||||
OPpASSIGN_BACKWARDS => 64,
|
||||
OPpASSIGN_COMMON => 64,
|
||||
OPpASSIGN_CV_TO_GV => 128,
|
||||
OPpCONST_BARE => 64,
|
||||
OPpCONST_ENTERED => 16,
|
||||
OPpCONST_NOVER => 2,
|
||||
OPpCONST_SHORTCIRCUIT => 4,
|
||||
OPpCONST_STRICT => 8,
|
||||
OPpCOREARGS_DEREF1 => 1,
|
||||
OPpCOREARGS_DEREF2 => 2,
|
||||
OPpCOREARGS_PUSHMARK => 128,
|
||||
OPpCOREARGS_SCALARMOD => 64,
|
||||
OPpDEREF => 48,
|
||||
OPpDEREF_AV => 16,
|
||||
OPpDEREF_HV => 32,
|
||||
OPpDEREF_SV => 48,
|
||||
OPpDONT_INIT_GV => 4,
|
||||
OPpEARLY_CV => 32,
|
||||
OPpENTERSUB_AMPER => 8,
|
||||
OPpENTERSUB_DB => 64,
|
||||
OPpENTERSUB_HASTARG => 4,
|
||||
OPpENTERSUB_INARGS => 1,
|
||||
OPpENTERSUB_NOPAREN => 128,
|
||||
OPpEVAL_BYTES => 8,
|
||||
OPpEVAL_COPHH => 16,
|
||||
OPpEVAL_HAS_HH => 2,
|
||||
OPpEVAL_RE_REPARSING => 32,
|
||||
OPpEVAL_UNICODE => 4,
|
||||
OPpEXISTS_SUB => 64,
|
||||
OPpFLIP_LINENUM => 64,
|
||||
OPpFT_ACCESS => 2,
|
||||
OPpFT_AFTER_t => 16,
|
||||
OPpFT_STACKED => 4,
|
||||
OPpFT_STACKING => 8,
|
||||
OPpGREP_LEX => 2,
|
||||
OPpHINT_STRICT_REFS => 2,
|
||||
OPpHUSH_VMSISH => 32,
|
||||
OPpITER_DEF => 8,
|
||||
OPpITER_REVERSED => 4,
|
||||
OPpLIST_GUESSED => 64,
|
||||
OPpLVALUE => 128,
|
||||
OPpLVAL_DEFER => 64,
|
||||
OPpLVAL_INTRO => 128,
|
||||
OPpLVREF_AV => 16,
|
||||
OPpLVREF_CV => 48,
|
||||
OPpLVREF_ELEM => 4,
|
||||
OPpLVREF_HV => 32,
|
||||
OPpLVREF_ITER => 8,
|
||||
OPpLVREF_SV => 0,
|
||||
OPpLVREF_TYPE => 48,
|
||||
OPpMAYBE_LVSUB => 8,
|
||||
OPpMAYBE_TRUEBOOL => 16,
|
||||
OPpMAY_RETURN_CONSTANT => 32,
|
||||
OPpMULTIDEREF_DELETE => 32,
|
||||
OPpMULTIDEREF_EXISTS => 16,
|
||||
OPpOFFBYONE => 128,
|
||||
OPpOPEN_IN_CRLF => 32,
|
||||
OPpOPEN_IN_RAW => 16,
|
||||
OPpOPEN_OUT_CRLF => 128,
|
||||
OPpOPEN_OUT_RAW => 64,
|
||||
OPpOUR_INTRO => 64,
|
||||
OPpPADRANGE_COUNTMASK => 127,
|
||||
OPpPADRANGE_COUNTSHIFT => 7,
|
||||
OPpPAD_STATE => 64,
|
||||
OPpPV_IS_UTF8 => 128,
|
||||
OPpREFCOUNTED => 64,
|
||||
OPpREPEAT_DOLIST => 64,
|
||||
OPpREVERSE_INPLACE => 8,
|
||||
OPpRUNTIME => 64,
|
||||
OPpSLICE => 64,
|
||||
OPpSLICEWARNING => 4,
|
||||
OPpSORT_DESCEND => 16,
|
||||
OPpSORT_INPLACE => 8,
|
||||
OPpSORT_INTEGER => 2,
|
||||
OPpSORT_NUMERIC => 1,
|
||||
OPpSORT_QSORT => 32,
|
||||
OPpSORT_REVERSE => 4,
|
||||
OPpSORT_STABLE => 64,
|
||||
OPpSPLIT_IMPLIM => 128,
|
||||
OPpSUBSTR_REPL_FIRST => 16,
|
||||
OPpTARGET_MY => 16,
|
||||
OPpTRANS_COMPLEMENT => 32,
|
||||
OPpTRANS_DELETE => 128,
|
||||
OPpTRANS_FROM_UTF => 1,
|
||||
OPpTRANS_GROWS => 64,
|
||||
OPpTRANS_IDENTICAL => 4,
|
||||
OPpTRANS_SQUASH => 8,
|
||||
OPpTRANS_TO_UTF => 2,
|
||||
OPpTRUEBOOL => 32,
|
||||
);
|
||||
|
||||
our %labels = (
|
||||
OPpALLOW_FAKE => 'FAKE',
|
||||
OPpASSIGN_BACKWARDS => 'BKWARD',
|
||||
OPpASSIGN_COMMON => 'COMMON',
|
||||
OPpASSIGN_CV_TO_GV => 'CV2GV',
|
||||
OPpCONST_BARE => 'BARE',
|
||||
OPpCONST_ENTERED => 'ENTERED',
|
||||
OPpCONST_NOVER => 'NOVER',
|
||||
OPpCONST_SHORTCIRCUIT => 'SHORT',
|
||||
OPpCONST_STRICT => 'STRICT',
|
||||
OPpCOREARGS_DEREF1 => 'DEREF1',
|
||||
OPpCOREARGS_DEREF2 => 'DEREF2',
|
||||
OPpCOREARGS_PUSHMARK => 'MARK',
|
||||
OPpCOREARGS_SCALARMOD => '$MOD',
|
||||
OPpDEREF_AV => 'DREFAV',
|
||||
OPpDEREF_HV => 'DREFHV',
|
||||
OPpDEREF_SV => 'DREFSV',
|
||||
OPpDONT_INIT_GV => 'NOINIT',
|
||||
OPpEARLY_CV => 'EARLYCV',
|
||||
OPpENTERSUB_AMPER => 'AMPER',
|
||||
OPpENTERSUB_DB => 'DBG',
|
||||
OPpENTERSUB_HASTARG => 'TARG',
|
||||
OPpENTERSUB_INARGS => 'INARGS',
|
||||
OPpENTERSUB_NOPAREN => 'NO()',
|
||||
OPpEVAL_BYTES => 'BYTES',
|
||||
OPpEVAL_COPHH => 'COPHH',
|
||||
OPpEVAL_HAS_HH => 'HAS_HH',
|
||||
OPpEVAL_RE_REPARSING => 'REPARSE',
|
||||
OPpEVAL_UNICODE => 'UNI',
|
||||
OPpEXISTS_SUB => 'SUB',
|
||||
OPpFLIP_LINENUM => 'LINENUM',
|
||||
OPpFT_ACCESS => 'FTACCESS',
|
||||
OPpFT_AFTER_t => 'FTAFTERt',
|
||||
OPpFT_STACKED => 'FTSTACKED',
|
||||
OPpFT_STACKING => 'FTSTACKING',
|
||||
OPpGREP_LEX => 'GREPLEX',
|
||||
OPpHINT_STRICT_REFS => 'STRICT',
|
||||
OPpHUSH_VMSISH => 'HUSH',
|
||||
OPpITER_DEF => 'DEF',
|
||||
OPpITER_REVERSED => 'REVERSED',
|
||||
OPpLIST_GUESSED => 'GUESSED',
|
||||
OPpLVALUE => 'LV',
|
||||
OPpLVAL_DEFER => 'LVDEFER',
|
||||
OPpLVAL_INTRO => 'LVINTRO',
|
||||
OPpLVREF_AV => 'AV',
|
||||
OPpLVREF_CV => 'CV',
|
||||
OPpLVREF_ELEM => 'ELEM',
|
||||
OPpLVREF_HV => 'HV',
|
||||
OPpLVREF_ITER => 'ITER',
|
||||
OPpLVREF_SV => 'SV',
|
||||
OPpMAYBE_LVSUB => 'LVSUB',
|
||||
OPpMAYBE_TRUEBOOL => 'BOOL?',
|
||||
OPpMAY_RETURN_CONSTANT => 'CONST',
|
||||
OPpMULTIDEREF_DELETE => 'DELETE',
|
||||
OPpMULTIDEREF_EXISTS => 'EXISTS',
|
||||
OPpOFFBYONE => '+1',
|
||||
OPpOPEN_IN_CRLF => 'INCR',
|
||||
OPpOPEN_IN_RAW => 'INBIN',
|
||||
OPpOPEN_OUT_CRLF => 'OUTCR',
|
||||
OPpOPEN_OUT_RAW => 'OUTBIN',
|
||||
OPpOUR_INTRO => 'OURINTR',
|
||||
OPpPAD_STATE => 'STATE',
|
||||
OPpPV_IS_UTF8 => 'UTF',
|
||||
OPpREFCOUNTED => 'REFC',
|
||||
OPpREPEAT_DOLIST => 'DOLIST',
|
||||
OPpREVERSE_INPLACE => 'INPLACE',
|
||||
OPpRUNTIME => 'RTIME',
|
||||
OPpSLICE => 'SLICE',
|
||||
OPpSLICEWARNING => 'SLICEWARN',
|
||||
OPpSORT_DESCEND => 'DESC',
|
||||
OPpSORT_INPLACE => 'INPLACE',
|
||||
OPpSORT_INTEGER => 'INT',
|
||||
OPpSORT_NUMERIC => 'NUM',
|
||||
OPpSORT_QSORT => 'QSORT',
|
||||
OPpSORT_REVERSE => 'REV',
|
||||
OPpSORT_STABLE => 'STABLE',
|
||||
OPpSPLIT_IMPLIM => 'IMPLIM',
|
||||
OPpSUBSTR_REPL_FIRST => 'REPL1ST',
|
||||
OPpTARGET_MY => 'TARGMY',
|
||||
OPpTRANS_COMPLEMENT => 'COMPL',
|
||||
OPpTRANS_DELETE => 'DEL',
|
||||
OPpTRANS_FROM_UTF => '<UTF',
|
||||
OPpTRANS_GROWS => 'GROWS',
|
||||
OPpTRANS_IDENTICAL => 'IDENT',
|
||||
OPpTRANS_SQUASH => 'SQUASH',
|
||||
OPpTRANS_TO_UTF => '>UTF',
|
||||
OPpTRUEBOOL => 'BOOL',
|
||||
);
|
||||
|
||||
|
||||
our %ops_using = (
|
||||
OPpALLOW_FAKE => [qw(rv2gv)],
|
||||
OPpASSIGN_BACKWARDS => [qw(sassign)],
|
||||
OPpASSIGN_COMMON => [qw(aassign)],
|
||||
OPpCONST_BARE => [qw(const)],
|
||||
OPpCOREARGS_DEREF1 => [qw(coreargs)],
|
||||
OPpEARLY_CV => [qw(gv)],
|
||||
OPpENTERSUB_AMPER => [qw(entersub rv2cv)],
|
||||
OPpENTERSUB_INARGS => [qw(entersub)],
|
||||
OPpENTERSUB_NOPAREN => [qw(rv2cv)],
|
||||
OPpEVAL_BYTES => [qw(entereval)],
|
||||
OPpEXISTS_SUB => [qw(exists)],
|
||||
OPpFLIP_LINENUM => [qw(flip flop)],
|
||||
OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)],
|
||||
OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)],
|
||||
OPpGREP_LEX => [qw(grepstart grepwhile mapstart mapwhile)],
|
||||
OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)],
|
||||
OPpHUSH_VMSISH => [qw(dbstate nextstate)],
|
||||
OPpITER_DEF => [qw(enteriter)],
|
||||
OPpITER_REVERSED => [qw(enteriter iter)],
|
||||
OPpLIST_GUESSED => [qw(list)],
|
||||
OPpLVALUE => [qw(leave leaveloop)],
|
||||
OPpLVAL_DEFER => [qw(aelem helem multideref)],
|
||||
OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv)],
|
||||
OPpLVREF_ELEM => [qw(lvref refassign)],
|
||||
OPpMAYBE_LVSUB => [qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice multideref padav padhv pos rkeys rv2av rv2gv rv2hv substr vec)],
|
||||
OPpMAYBE_TRUEBOOL => [qw(padhv rv2hv)],
|
||||
OPpMULTIDEREF_DELETE => [qw(multideref)],
|
||||
OPpOFFBYONE => [qw(caller runcv wantarray)],
|
||||
OPpOPEN_IN_CRLF => [qw(backtick open)],
|
||||
OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)],
|
||||
OPpPAD_STATE => [qw(lvavref lvref padav padhv padsv pushmark refassign)],
|
||||
OPpPV_IS_UTF8 => [qw(dump goto last next redo)],
|
||||
OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)],
|
||||
OPpREPEAT_DOLIST => [qw(repeat)],
|
||||
OPpREVERSE_INPLACE => [qw(reverse)],
|
||||
OPpRUNTIME => [qw(match pushre qr subst substcont)],
|
||||
OPpSLICE => [qw(delete)],
|
||||
OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)],
|
||||
OPpSORT_DESCEND => [qw(sort)],
|
||||
OPpSPLIT_IMPLIM => [qw(split)],
|
||||
OPpSUBSTR_REPL_FIRST => [qw(substr)],
|
||||
OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push pushre qr rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid)],
|
||||
OPpTRANS_COMPLEMENT => [qw(trans transr)],
|
||||
);
|
||||
|
||||
$ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS};
|
||||
$ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCONST_STRICT} = $ops_using{OPpCONST_BARE};
|
||||
$ops_using{OPpCOREARGS_DEREF2} = $ops_using{OPpCOREARGS_DEREF1};
|
||||
$ops_using{OPpCOREARGS_PUSHMARK} = $ops_using{OPpCOREARGS_DEREF1};
|
||||
$ops_using{OPpCOREARGS_SCALARMOD} = $ops_using{OPpCOREARGS_DEREF1};
|
||||
$ops_using{OPpDONT_INIT_GV} = $ops_using{OPpALLOW_FAKE};
|
||||
$ops_using{OPpENTERSUB_DB} = $ops_using{OPpENTERSUB_AMPER};
|
||||
$ops_using{OPpENTERSUB_HASTARG} = $ops_using{OPpENTERSUB_AMPER};
|
||||
$ops_using{OPpEVAL_COPHH} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpEVAL_HAS_HH} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpEVAL_RE_REPARSING} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpEVAL_UNICODE} = $ops_using{OPpEVAL_BYTES};
|
||||
$ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t};
|
||||
$ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t};
|
||||
$ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM};
|
||||
$ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN};
|
||||
$ops_using{OPpMULTIDEREF_EXISTS} = $ops_using{OPpMULTIDEREF_DELETE};
|
||||
$ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF};
|
||||
$ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF};
|
||||
$ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF};
|
||||
$ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_NUMERIC} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_QSORT} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpSORT_STABLE} = $ops_using{OPpSORT_DESCEND};
|
||||
$ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_COMPLEMENT};
|
||||
$ops_using{OPpTRANS_FROM_UTF} = $ops_using{OPpTRANS_COMPLEMENT};
|
||||
$ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_COMPLEMENT};
|
||||
$ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_COMPLEMENT};
|
||||
$ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_COMPLEMENT};
|
||||
$ops_using{OPpTRANS_TO_UTF} = $ops_using{OPpTRANS_COMPLEMENT};
|
||||
$ops_using{OPpTRUEBOOL} = $ops_using{OPpMAYBE_TRUEBOOL};
|
||||
|
||||
# ex: set ro:
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,96 @@
|
|||
=head1 NAME
|
||||
|
||||
CORE - Namespace for Perl's core routines
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
BEGIN {
|
||||
*CORE::GLOBAL::hex = sub { 1; };
|
||||
}
|
||||
|
||||
print hex("0x50"),"\n"; # prints 1
|
||||
print CORE::hex("0x50"),"\n"; # prints 80
|
||||
CORE::say "yes"; # prints yes
|
||||
|
||||
BEGIN { *shove = \&CORE::push; }
|
||||
shove @array, 1,2,3; # pushes on to @array
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<CORE> namespace gives access to the original built-in functions of
|
||||
Perl. The C<CORE> package is built into
|
||||
Perl, and therefore you do not need to use or
|
||||
require a hypothetical "CORE" module prior to accessing routines in this
|
||||
namespace.
|
||||
|
||||
A list of the built-in functions in Perl can be found in L<perlfunc>.
|
||||
|
||||
For all Perl keywords, a C<CORE::> prefix will force the built-in function
|
||||
to be used, even if it has been overridden or would normally require the
|
||||
L<feature> pragma. Despite appearances, this has nothing to do with the
|
||||
CORE package, but is part of Perl's syntax.
|
||||
|
||||
For many Perl functions, the CORE package contains real subroutines. This
|
||||
feature is new in Perl 5.16. You can take references to these and make
|
||||
aliases. However, some can only be called as barewords; i.e., you cannot
|
||||
use ampersand syntax (C<&foo>) or call them through references. See the
|
||||
C<shove> example above. These subroutines exist for all keywords except the following:
|
||||
|
||||
C<__DATA__>, C<__END__>, C<and>, C<cmp>, C<default>, C<do>, C<dump>,
|
||||
C<else>, C<elsif>, C<eq>, C<eval>, C<for>, C<foreach>, C<format>, C<ge>,
|
||||
C<given>, C<goto>, C<grep>, C<gt>, C<if>, C<last>, C<le>, C<local>, C<lt>,
|
||||
C<m>, C<map>, C<my>, C<ne>, C<next>, C<no>, C<or>, C<our>, C<package>,
|
||||
C<print>, C<printf>, C<q>, C<qq>, C<qr>, C<qw>, C<qx>, C<redo>, C<require>,
|
||||
C<return>, C<s>, C<say>, C<sort>, C<state>, C<sub>, C<tr>, C<unless>,
|
||||
C<until>, C<use>, C<when>, C<while>, C<x>, C<xor>, C<y>
|
||||
|
||||
Calling with
|
||||
ampersand syntax and through references does not work for the following
|
||||
functions, as they have special syntax that cannot always be translated
|
||||
into a simple list (e.g., C<eof> vs C<eof()>):
|
||||
|
||||
C<chdir>, C<chomp>, C<chop>, C<defined>, C<delete>, C<each>,
|
||||
C<eof>, C<exec>, C<exists>, C<keys>, C<lstat>, C<pop>, C<push>,
|
||||
C<shift>, C<splice>, C<split>, C<stat>, C<system>, C<truncate>,
|
||||
C<unlink>, C<unshift>, C<values>
|
||||
|
||||
=head1 OVERRIDING CORE FUNCTIONS
|
||||
|
||||
To override a Perl built-in routine with your own version, you need to
|
||||
import it at compile-time. This can be conveniently achieved with the
|
||||
C<subs> pragma. This will affect only the package in which you've imported
|
||||
the said subroutine:
|
||||
|
||||
use subs 'chdir';
|
||||
sub chdir { ... }
|
||||
chdir $somewhere;
|
||||
|
||||
To override a built-in globally (that is, in all namespaces), you need to
|
||||
import your function into the C<CORE::GLOBAL> pseudo-namespace at compile
|
||||
time:
|
||||
|
||||
BEGIN {
|
||||
*CORE::GLOBAL::hex = sub {
|
||||
# ... your code here
|
||||
};
|
||||
}
|
||||
|
||||
The new routine will be called whenever a built-in function is called
|
||||
without a qualifying package:
|
||||
|
||||
print hex("0x50"),"\n"; # prints 1
|
||||
|
||||
In both cases, if you want access to the original, unaltered routine, use
|
||||
the C<CORE::> prefix:
|
||||
|
||||
print CORE::hex("0x50"),"\n"; # prints 80
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This documentation provided by Tels <nospam-abuse@bloodgate.com> 2007.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlsub>, L<perlfunc>.
|
||||
|
||||
=cut
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,44 @@
|
|||
=head1 NAME
|
||||
|
||||
CPAN::API::HOWTO - a recipe book for programming with CPAN.pm
|
||||
|
||||
=head1 RECIPES
|
||||
|
||||
All of these recipes assume that you have put "use CPAN" at the top of
|
||||
your program.
|
||||
|
||||
=head2 What distribution contains a particular module?
|
||||
|
||||
my $distribution = CPAN::Shell->expand(
|
||||
"Module", "Data::UUID"
|
||||
)->distribution()->pretty_id();
|
||||
|
||||
This returns a string of the form "AUTHORID/TARBALL". If you want the
|
||||
full path and filename to this distribution on a CPAN mirror, then it is
|
||||
C<.../authors/id/A/AU/AUTHORID/TARBALL>.
|
||||
|
||||
=head2 What modules does a particular distribution contain?
|
||||
|
||||
CPAN::Index->reload();
|
||||
my @modules = CPAN::Shell->expand(
|
||||
"Distribution", "JHI/Graph-0.83.tar.gz"
|
||||
)->containsmods();
|
||||
|
||||
You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
the main CPAN.pm documentation
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
See L<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
David Cantrell
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,236 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::Author;
|
||||
use strict;
|
||||
|
||||
use CPAN::InfoObj;
|
||||
@CPAN::Author::ISA = qw(CPAN::InfoObj);
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "5.5002";
|
||||
|
||||
package CPAN::Author;
|
||||
use strict;
|
||||
|
||||
#-> sub CPAN::Author::force
|
||||
sub force {
|
||||
my $self = shift;
|
||||
$self->{force}++;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Author::force
|
||||
sub unforce {
|
||||
my $self = shift;
|
||||
delete $self->{force};
|
||||
}
|
||||
|
||||
#-> sub CPAN::Author::id
|
||||
sub id {
|
||||
my $self = shift;
|
||||
my $id = $self->{ID};
|
||||
$CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
|
||||
$id;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Author::as_glimpse ;
|
||||
sub as_glimpse {
|
||||
my($self) = @_;
|
||||
my(@m);
|
||||
my $class = ref($self);
|
||||
$class =~ s/^CPAN:://;
|
||||
push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
|
||||
$class,
|
||||
$self->{ID},
|
||||
$self->fullname,
|
||||
$self->email);
|
||||
join "", @m;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Author::fullname ;
|
||||
sub fullname {
|
||||
shift->ro->{FULLNAME};
|
||||
}
|
||||
*name = \&fullname;
|
||||
|
||||
#-> sub CPAN::Author::email ;
|
||||
sub email { shift->ro->{EMAIL}; }
|
||||
|
||||
#-> sub CPAN::Author::ls ;
|
||||
sub ls {
|
||||
my $self = shift;
|
||||
my $glob = shift || "";
|
||||
my $silent = shift || 0;
|
||||
my $id = $self->id;
|
||||
|
||||
# adapted from CPAN::Distribution::verifyCHECKSUM ;
|
||||
my(@csf); # chksumfile
|
||||
@csf = $self->id =~ /(.)(.)(.*)/;
|
||||
$csf[1] = join "", @csf[0,1];
|
||||
$csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
|
||||
my(@dl);
|
||||
@dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
|
||||
unless (grep {$_->[2] eq $csf[1]} @dl) {
|
||||
$CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
|
||||
return;
|
||||
}
|
||||
@dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
|
||||
unless (grep {$_->[2] eq $csf[2]} @dl) {
|
||||
$CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
|
||||
return;
|
||||
}
|
||||
@dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
|
||||
if ($glob) {
|
||||
if ($CPAN::META->has_inst("Text::Glob")) {
|
||||
$glob =~ s|/$|/*|;
|
||||
my $rglob = Text::Glob::glob_to_regex($glob);
|
||||
CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
|
||||
my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl;
|
||||
if (1==@tmpdl && $tmpdl[0][0]==0) {
|
||||
$rglob = Text::Glob::glob_to_regex("$glob/*");
|
||||
@dl = grep { $_->[2] =~ /$rglob/ } @dl;
|
||||
} else {
|
||||
@dl = @tmpdl;
|
||||
}
|
||||
CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
|
||||
} else {
|
||||
$CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
|
||||
}
|
||||
}
|
||||
unless ($silent >= 2) {
|
||||
$CPAN::Frontend->myprint
|
||||
(
|
||||
join "",
|
||||
map {
|
||||
sprintf
|
||||
(
|
||||
"%8d %10s %s/%s%s\n",
|
||||
$_->[0],
|
||||
$_->[1],
|
||||
$id,
|
||||
$_->[2],
|
||||
0==$_->[0]?"/":"",
|
||||
)
|
||||
} sort { $a->[2] cmp $b->[2] } @dl
|
||||
);
|
||||
}
|
||||
@dl;
|
||||
}
|
||||
|
||||
# returns an array of arrays, the latter contain (size,mtime,filename)
|
||||
#-> sub CPAN::Author::dir_listing ;
|
||||
sub dir_listing {
|
||||
my $self = shift;
|
||||
my $chksumfile = shift;
|
||||
my $recursive = shift;
|
||||
my $may_ftp = shift;
|
||||
|
||||
my $lc_want =
|
||||
File::Spec->catfile($CPAN::Config->{keep_source_where},
|
||||
"authors", "id", @$chksumfile);
|
||||
|
||||
my $fh;
|
||||
|
||||
CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG;
|
||||
# Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
|
||||
# hazard. (Without GPG installed they are not that much better,
|
||||
# though.)
|
||||
$fh = FileHandle->new;
|
||||
if (open($fh, $lc_want)) {
|
||||
my $line = <$fh>; close $fh;
|
||||
unlink($lc_want) unless $line =~ /PGP/;
|
||||
}
|
||||
|
||||
local($") = "/";
|
||||
# connect "force" argument with "index_expire".
|
||||
my $force = $self->{force};
|
||||
if (my @stat = stat $lc_want) {
|
||||
$force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
|
||||
}
|
||||
my $lc_file;
|
||||
if ($may_ftp) {
|
||||
$lc_file = eval {
|
||||
CPAN::FTP->localize
|
||||
(
|
||||
"authors/id/@$chksumfile",
|
||||
$lc_want,
|
||||
$force,
|
||||
);
|
||||
};
|
||||
unless ($lc_file) {
|
||||
$CPAN::Frontend->myprint("Trying $lc_want.gz\n");
|
||||
$chksumfile->[-1] .= ".gz";
|
||||
$lc_file = eval {
|
||||
CPAN::FTP->localize
|
||||
("authors/id/@$chksumfile",
|
||||
"$lc_want.gz",
|
||||
1,
|
||||
);
|
||||
};
|
||||
if ($lc_file) {
|
||||
$lc_file =~ s{\.gz(?!\n)\Z}{}; #};
|
||||
eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$lc_file = $lc_want;
|
||||
# we *could* second-guess and if the user has a file: URL,
|
||||
# then we could look there. But on the other hand, if they do
|
||||
# have a file: URL, why did they choose to set
|
||||
# $CPAN::Config->{show_upload_date} to false?
|
||||
}
|
||||
|
||||
# adapted from CPAN::Distribution::CHECKSUM_check_file ;
|
||||
$fh = FileHandle->new;
|
||||
my($cksum);
|
||||
if (open $fh, $lc_file) {
|
||||
local($/);
|
||||
my $eval = <$fh>;
|
||||
$eval =~ s/\015?\012/\n/g;
|
||||
close $fh;
|
||||
my($compmt) = Safe->new();
|
||||
$cksum = $compmt->reval($eval);
|
||||
if ($@) {
|
||||
rename $lc_file, "$lc_file.bad";
|
||||
Carp::confess($@) if $@;
|
||||
}
|
||||
} elsif ($may_ftp) {
|
||||
Carp::carp ("Could not open '$lc_file' for reading.");
|
||||
} else {
|
||||
# Maybe should warn: "You may want to set show_upload_date to a true value"
|
||||
return;
|
||||
}
|
||||
my(@result,$f);
|
||||
for $f (sort keys %$cksum) {
|
||||
if (exists $cksum->{$f}{isdir}) {
|
||||
if ($recursive) {
|
||||
my(@dir) = @$chksumfile;
|
||||
pop @dir;
|
||||
push @dir, $f, "CHECKSUMS";
|
||||
push @result, [ 0, "-", $f ];
|
||||
push @result, map {
|
||||
[$_->[0], $_->[1], "$f/$_->[2]"]
|
||||
} $self->dir_listing(\@dir,1,$may_ftp);
|
||||
} else {
|
||||
push @result, [ 0, "-", $f ];
|
||||
}
|
||||
} else {
|
||||
push @result, [
|
||||
($cksum->{$f}{"size"}||0),
|
||||
$cksum->{$f}{"mtime"}||"---",
|
||||
$f
|
||||
];
|
||||
}
|
||||
}
|
||||
@result;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Author::reports
|
||||
sub reports {
|
||||
$CPAN::Frontend->mywarn("reports on authors not implemented.
|
||||
Please file a bugreport if you need this.\n");
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,290 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::Bundle;
|
||||
use strict;
|
||||
use CPAN::Module;
|
||||
@CPAN::Bundle::ISA = qw(CPAN::Module);
|
||||
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "5.5001";
|
||||
|
||||
sub look {
|
||||
my $self = shift;
|
||||
$CPAN::Frontend->myprint($self->as_string);
|
||||
}
|
||||
|
||||
#-> CPAN::Bundle::undelay
|
||||
sub undelay {
|
||||
my $self = shift;
|
||||
delete $self->{later};
|
||||
for my $c ( $self->contains ) {
|
||||
my $obj = CPAN::Shell->expandany($c) or next;
|
||||
$obj->undelay;
|
||||
}
|
||||
}
|
||||
|
||||
# mark as dirty/clean
|
||||
#-> sub CPAN::Bundle::color_cmd_tmps ;
|
||||
sub color_cmd_tmps {
|
||||
my($self) = shift;
|
||||
my($depth) = shift || 0;
|
||||
my($color) = shift || 0;
|
||||
my($ancestors) = shift || [];
|
||||
# a module needs to recurse to its cpan_file, a distribution needs
|
||||
# to recurse into its prereq_pms, a bundle needs to recurse into its modules
|
||||
|
||||
return if exists $self->{incommandcolor}
|
||||
&& $color==1
|
||||
&& $self->{incommandcolor}==$color;
|
||||
if ($depth>=$CPAN::MAX_RECURSION) {
|
||||
die(CPAN::Exception::RecursiveDependency->new($ancestors));
|
||||
}
|
||||
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
|
||||
|
||||
for my $c ( $self->contains ) {
|
||||
my $obj = CPAN::Shell->expandany($c) or next;
|
||||
CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
|
||||
$obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
|
||||
}
|
||||
# never reached code?
|
||||
#if ($color==0) {
|
||||
#delete $self->{badtestcnt};
|
||||
#}
|
||||
$self->{incommandcolor} = $color;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Bundle::as_string ;
|
||||
sub as_string {
|
||||
my($self) = @_;
|
||||
$self->contains;
|
||||
# following line must be "=", not "||=" because we have a moving target
|
||||
$self->{INST_VERSION} = $self->inst_version;
|
||||
return $self->SUPER::as_string;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Bundle::contains ;
|
||||
sub contains {
|
||||
my($self) = @_;
|
||||
my($inst_file) = $self->inst_file || "";
|
||||
my($id) = $self->id;
|
||||
$self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
|
||||
if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
|
||||
undef $inst_file;
|
||||
}
|
||||
unless ($inst_file) {
|
||||
# Try to get at it in the cpan directory
|
||||
$self->debug("no inst_file") if $CPAN::DEBUG;
|
||||
my $cpan_file;
|
||||
$CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
|
||||
$cpan_file = $self->cpan_file;
|
||||
if ($cpan_file eq "N/A") {
|
||||
$CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
|
||||
Maybe stale symlink? Maybe removed during session? Giving up.\n");
|
||||
}
|
||||
my $dist = $CPAN::META->instance('CPAN::Distribution',
|
||||
$self->cpan_file);
|
||||
$self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
|
||||
$dist->get;
|
||||
$self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
|
||||
my($todir) = $CPAN::Config->{'cpan_home'};
|
||||
my(@me,$from,$to,$me);
|
||||
@me = split /::/, $self->id;
|
||||
$me[-1] .= ".pm";
|
||||
$me = File::Spec->catfile(@me);
|
||||
$from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
|
||||
$to = File::Spec->catfile($todir,$me);
|
||||
File::Path::mkpath(File::Basename::dirname($to));
|
||||
File::Copy::copy($from, $to)
|
||||
or Carp::confess("Couldn't copy $from to $to: $!");
|
||||
$inst_file = $to;
|
||||
}
|
||||
my @result;
|
||||
my $fh = FileHandle->new;
|
||||
local $/ = "\n";
|
||||
open($fh,$inst_file) or die "Could not open '$inst_file': $!";
|
||||
my $in_cont = 0;
|
||||
$self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
|
||||
while (<$fh>) {
|
||||
$in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
|
||||
m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
|
||||
next unless $in_cont;
|
||||
next if /^=/;
|
||||
s/\#.*//;
|
||||
next if /^\s+$/;
|
||||
chomp;
|
||||
push @result, (split " ", $_, 2)[0];
|
||||
}
|
||||
close $fh;
|
||||
delete $self->{STATUS};
|
||||
$self->{CONTAINS} = \@result;
|
||||
$self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
|
||||
unless (@result) {
|
||||
$CPAN::Frontend->mywarn(qq{
|
||||
The bundle file "$inst_file" may be a broken
|
||||
bundlefile. It seems not to contain any bundle definition.
|
||||
Please check the file and if it is bogus, please delete it.
|
||||
Sorry for the inconvenience.
|
||||
});
|
||||
}
|
||||
@result;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Bundle::find_bundle_file
|
||||
# $where is in local format, $what is in unix format
|
||||
sub find_bundle_file {
|
||||
my($self,$where,$what) = @_;
|
||||
$self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
|
||||
### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
|
||||
### my $bu = File::Spec->catfile($where,$what);
|
||||
### return $bu if -f $bu;
|
||||
my $manifest = File::Spec->catfile($where,"MANIFEST");
|
||||
unless (-f $manifest) {
|
||||
require ExtUtils::Manifest;
|
||||
my $cwd = CPAN::anycwd();
|
||||
$self->safe_chdir($where);
|
||||
ExtUtils::Manifest::mkmanifest();
|
||||
$self->safe_chdir($cwd);
|
||||
}
|
||||
my $fh = FileHandle->new($manifest)
|
||||
or Carp::croak("Couldn't open $manifest: $!");
|
||||
local($/) = "\n";
|
||||
my $bundle_filename = $what;
|
||||
$bundle_filename =~ s|Bundle.*/||;
|
||||
my $bundle_unixpath;
|
||||
while (<$fh>) {
|
||||
next if /^\s*\#/;
|
||||
my($file) = /(\S+)/;
|
||||
if ($file =~ m|\Q$what\E$|) {
|
||||
$bundle_unixpath = $file;
|
||||
# return File::Spec->catfile($where,$bundle_unixpath); # bad
|
||||
last;
|
||||
}
|
||||
# retry if she managed to have no Bundle directory
|
||||
$bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
|
||||
}
|
||||
return File::Spec->catfile($where, split /\//, $bundle_unixpath)
|
||||
if $bundle_unixpath;
|
||||
Carp::croak("Couldn't find a Bundle file in $where");
|
||||
}
|
||||
|
||||
# needs to work quite differently from Module::inst_file because of
|
||||
# cpan_home/Bundle/ directory and the possibility that we have
|
||||
# shadowing effect. As it makes no sense to take the first in @INC for
|
||||
# Bundles, we parse them all for $VERSION and take the newest.
|
||||
|
||||
#-> sub CPAN::Bundle::inst_file ;
|
||||
sub inst_file {
|
||||
my($self) = @_;
|
||||
my($inst_file);
|
||||
my(@me);
|
||||
@me = split /::/, $self->id;
|
||||
$me[-1] .= ".pm";
|
||||
my($incdir,$bestv);
|
||||
foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
|
||||
my $parsefile = File::Spec->catfile($incdir, @me);
|
||||
CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
|
||||
next unless -f $parsefile;
|
||||
my $have = eval { MM->parse_version($parsefile); };
|
||||
if ($@) {
|
||||
$CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
|
||||
}
|
||||
if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
|
||||
$self->{INST_FILE} = $parsefile;
|
||||
$self->{INST_VERSION} = $bestv = $have;
|
||||
}
|
||||
}
|
||||
$self->{INST_FILE};
|
||||
}
|
||||
|
||||
#-> sub CPAN::Bundle::inst_version ;
|
||||
sub inst_version {
|
||||
my($self) = @_;
|
||||
$self->inst_file; # finds INST_VERSION as side effect
|
||||
$self->{INST_VERSION};
|
||||
}
|
||||
|
||||
#-> sub CPAN::Bundle::rematein ;
|
||||
sub rematein {
|
||||
my($self,$meth) = @_;
|
||||
$self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
|
||||
my($id) = $self->id;
|
||||
Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" )
|
||||
unless $self->inst_file || $self->cpan_file;
|
||||
my($s,%fail);
|
||||
for $s ($self->contains) {
|
||||
my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
|
||||
$s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
|
||||
if ($type eq 'CPAN::Distribution') {
|
||||
$CPAN::Frontend->mywarn(qq{
|
||||
The Bundle }.$self->id.qq{ contains
|
||||
explicitly a file '$s'.
|
||||
Going to $meth that.
|
||||
});
|
||||
$CPAN::Frontend->mysleep(5);
|
||||
}
|
||||
# possibly noisy action:
|
||||
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
|
||||
my $obj = $CPAN::META->instance($type,$s);
|
||||
$obj->{reqtype} = $self->{reqtype};
|
||||
# $obj->$meth();
|
||||
# XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
|
||||
# A: Sure, what could demand otherwise? --andk, 2013-11-25
|
||||
CPAN::Queue->queue_item(qmod => $obj->id, reqtype => $self->{reqtype}, optional => !$self->{mandatory});
|
||||
}
|
||||
}
|
||||
|
||||
# If a bundle contains another that contains an xs_file we have here,
|
||||
# we just don't bother I suppose
|
||||
#-> sub CPAN::Bundle::xs_file
|
||||
sub xs_file {
|
||||
return 0;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Bundle::force ;
|
||||
sub fforce { shift->rematein('fforce',@_); }
|
||||
#-> sub CPAN::Bundle::force ;
|
||||
sub force { shift->rematein('force',@_); }
|
||||
#-> sub CPAN::Bundle::notest ;
|
||||
sub notest { shift->rematein('notest',@_); }
|
||||
#-> sub CPAN::Bundle::get ;
|
||||
sub get { shift->rematein('get',@_); }
|
||||
#-> sub CPAN::Bundle::make ;
|
||||
sub make { shift->rematein('make',@_); }
|
||||
#-> sub CPAN::Bundle::test ;
|
||||
sub test {
|
||||
my $self = shift;
|
||||
# $self->{badtestcnt} ||= 0;
|
||||
$self->rematein('test',@_);
|
||||
}
|
||||
#-> sub CPAN::Bundle::install ;
|
||||
sub install {
|
||||
my $self = shift;
|
||||
$self->rematein('install',@_);
|
||||
}
|
||||
#-> sub CPAN::Bundle::clean ;
|
||||
sub clean { shift->rematein('clean',@_); }
|
||||
|
||||
#-> sub CPAN::Bundle::uptodate ;
|
||||
sub uptodate {
|
||||
my($self) = @_;
|
||||
return 0 unless $self->SUPER::uptodate; # we must have the current Bundle def
|
||||
my $c;
|
||||
foreach $c ($self->contains) {
|
||||
my $obj = CPAN::Shell->expandany($c);
|
||||
return 0 unless $obj->uptodate;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Bundle::readme ;
|
||||
sub readme {
|
||||
my($self) = @_;
|
||||
my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
|
||||
No File found for bundle } . $self->id . qq{\n}), return;
|
||||
$self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
|
||||
$CPAN::META->instance('CPAN::Distribution',$file)->readme;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,249 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::CacheMgr;
|
||||
use strict;
|
||||
use CPAN::InfoObj;
|
||||
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
|
||||
use Cwd qw(chdir);
|
||||
use File::Find;
|
||||
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "5.5002";
|
||||
|
||||
package CPAN::CacheMgr;
|
||||
use strict;
|
||||
|
||||
#-> sub CPAN::CacheMgr::as_string ;
|
||||
sub as_string {
|
||||
eval { require Data::Dumper };
|
||||
if ($@) {
|
||||
return shift->SUPER::as_string;
|
||||
} else {
|
||||
return Data::Dumper::Dumper(shift);
|
||||
}
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::cachesize ;
|
||||
sub cachesize {
|
||||
shift->{DU};
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::tidyup ;
|
||||
sub tidyup {
|
||||
my($self) = @_;
|
||||
return unless $CPAN::META->{LOCK};
|
||||
return unless -d $self->{ID};
|
||||
my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
|
||||
for my $current (0..$#toremove) {
|
||||
my $toremove = $toremove[$current];
|
||||
$CPAN::Frontend->myprint(sprintf(
|
||||
"DEL(%d/%d): %s \n",
|
||||
$current+1,
|
||||
scalar @toremove,
|
||||
$toremove,
|
||||
)
|
||||
);
|
||||
return if $CPAN::Signal;
|
||||
$self->_clean_cache($toremove);
|
||||
return if $CPAN::Signal;
|
||||
}
|
||||
$self->{FIFO} = [];
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::dir ;
|
||||
sub dir {
|
||||
shift->{ID};
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::entries ;
|
||||
sub entries {
|
||||
my($self,$dir) = @_;
|
||||
return unless defined $dir;
|
||||
$self->debug("reading dir[$dir]") if $CPAN::DEBUG;
|
||||
$dir ||= $self->{ID};
|
||||
my($cwd) = CPAN::anycwd();
|
||||
chdir $dir or Carp::croak("Can't chdir to $dir: $!");
|
||||
my $dh = DirHandle->new(File::Spec->curdir)
|
||||
or Carp::croak("Couldn't opendir $dir: $!");
|
||||
my(@entries);
|
||||
for ($dh->read) {
|
||||
next if $_ eq "." || $_ eq "..";
|
||||
if (-f $_) {
|
||||
push @entries, File::Spec->catfile($dir,$_);
|
||||
} elsif (-d _) {
|
||||
push @entries, File::Spec->catdir($dir,$_);
|
||||
} else {
|
||||
$CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
|
||||
}
|
||||
}
|
||||
chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
|
||||
sort { -M $a <=> -M $b} @entries;
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::disk_usage ;
|
||||
sub disk_usage {
|
||||
my($self,$dir,$fast) = @_;
|
||||
return if exists $self->{SIZE}{$dir};
|
||||
return if $CPAN::Signal;
|
||||
my($Du) = 0;
|
||||
if (-e $dir) {
|
||||
if (-d $dir) {
|
||||
unless (-x $dir) {
|
||||
unless (chmod 0755, $dir) {
|
||||
$CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
|
||||
"permission to change the permission; cannot ".
|
||||
"estimate disk usage of '$dir'\n");
|
||||
$CPAN::Frontend->mysleep(5);
|
||||
return;
|
||||
}
|
||||
}
|
||||
} elsif (-f $dir) {
|
||||
# nothing to say, no matter what the permissions
|
||||
}
|
||||
} else {
|
||||
$CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
|
||||
return;
|
||||
}
|
||||
if ($fast) {
|
||||
$Du = 0; # placeholder
|
||||
} else {
|
||||
find(
|
||||
sub {
|
||||
$File::Find::prune++ if $CPAN::Signal;
|
||||
return if -l $_;
|
||||
if ($^O eq 'MacOS') {
|
||||
require Mac::Files;
|
||||
my $cat = Mac::Files::FSpGetCatInfo($_);
|
||||
$Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
|
||||
} else {
|
||||
if (-d _) {
|
||||
unless (-x _) {
|
||||
unless (chmod 0755, $_) {
|
||||
$CPAN::Frontend->mywarn("I have neither the -x permission nor ".
|
||||
"the permission to change the permission; ".
|
||||
"can only partially estimate disk usage ".
|
||||
"of '$_'\n");
|
||||
$CPAN::Frontend->mysleep(5);
|
||||
return;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$Du += (-s _);
|
||||
}
|
||||
}
|
||||
},
|
||||
$dir
|
||||
);
|
||||
}
|
||||
return if $CPAN::Signal;
|
||||
$self->{SIZE}{$dir} = $Du/1024/1024;
|
||||
unshift @{$self->{FIFO}}, $dir;
|
||||
$self->debug("measured $dir is $Du") if $CPAN::DEBUG;
|
||||
$self->{DU} += $Du/1024/1024;
|
||||
$self->{DU};
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::_clean_cache ;
|
||||
sub _clean_cache {
|
||||
my($self,$dir) = @_;
|
||||
return unless -e $dir;
|
||||
unless (File::Spec->canonpath(File::Basename::dirname($dir))
|
||||
eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
|
||||
$CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
|
||||
"will not remove\n");
|
||||
$CPAN::Frontend->mysleep(5);
|
||||
return;
|
||||
}
|
||||
$self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
|
||||
if $CPAN::DEBUG;
|
||||
File::Path::rmtree($dir);
|
||||
my $id_deleted = 0;
|
||||
if ($dir !~ /\.yml$/ && -f "$dir.yml") {
|
||||
my $yaml_module = CPAN::_yaml_module();
|
||||
if ($CPAN::META->has_inst($yaml_module)) {
|
||||
my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
|
||||
if ($@) {
|
||||
$CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
|
||||
unlink "$dir.yml" or
|
||||
$CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
|
||||
return;
|
||||
} elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
|
||||
$CPAN::META->delete("CPAN::Distribution", $id);
|
||||
|
||||
# XXX we should restore the state NOW, otherwise this
|
||||
# distro does not exist until we read an index. BUG ALERT(?)
|
||||
|
||||
# $CPAN::Frontend->mywarn (" +++\n");
|
||||
$id_deleted++;
|
||||
}
|
||||
}
|
||||
unlink "$dir.yml"; # may fail
|
||||
unless ($id_deleted) {
|
||||
CPAN->debug("no distro found associated with '$dir'");
|
||||
}
|
||||
}
|
||||
$self->{DU} -= $self->{SIZE}{$dir};
|
||||
delete $self->{SIZE}{$dir};
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::new ;
|
||||
sub new {
|
||||
my($class,$phase) = @_;
|
||||
$phase ||= "atstart";
|
||||
my $time = time;
|
||||
my($debug,$t2);
|
||||
$debug = "";
|
||||
my $self = {
|
||||
ID => $CPAN::Config->{build_dir},
|
||||
MAX => $CPAN::Config->{'build_cache'},
|
||||
SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
|
||||
DU => 0
|
||||
};
|
||||
$CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
|
||||
unless $self->{SCAN} =~ /never|atstart|atexit/;
|
||||
File::Path::mkpath($self->{ID});
|
||||
my $dh = DirHandle->new($self->{ID});
|
||||
bless $self, $class;
|
||||
$self->scan_cache($phase);
|
||||
$t2 = time;
|
||||
$debug .= "timing of CacheMgr->new: ".($t2 - $time);
|
||||
$time = $t2;
|
||||
CPAN->debug($debug) if $CPAN::DEBUG;
|
||||
$self;
|
||||
}
|
||||
|
||||
#-> sub CPAN::CacheMgr::scan_cache ;
|
||||
sub scan_cache {
|
||||
my ($self, $phase) = @_;
|
||||
$phase = '' unless defined $phase;
|
||||
return unless $phase eq $self->{SCAN};
|
||||
return unless $CPAN::META->{LOCK};
|
||||
$CPAN::Frontend->myprint(
|
||||
sprintf("Scanning cache %s for sizes\n",
|
||||
$self->{ID}));
|
||||
my $e;
|
||||
my @entries = $self->entries($self->{ID});
|
||||
my $i = 0;
|
||||
my $painted = 0;
|
||||
for $e (@entries) {
|
||||
my $symbol = ".";
|
||||
if ($self->{DU} > $self->{MAX}) {
|
||||
$symbol = "-";
|
||||
$self->disk_usage($e,1);
|
||||
} else {
|
||||
$self->disk_usage($e);
|
||||
}
|
||||
$i++;
|
||||
while (($painted/76) < ($i/@entries)) {
|
||||
$CPAN::Frontend->myprint($symbol);
|
||||
$painted++;
|
||||
}
|
||||
return if $CPAN::Signal;
|
||||
}
|
||||
$CPAN::Frontend->myprint("DONE\n");
|
||||
$self->tidyup;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,175 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::Complete;
|
||||
use strict;
|
||||
@CPAN::Complete::ISA = qw(CPAN::Debug);
|
||||
# Q: where is the "How do I add a new command" HOWTO?
|
||||
# A: git log -p -1 355c44e9caaec857e4b12f51afb96498833c3e36 where andk added the report command
|
||||
@CPAN::Complete::COMMANDS = sort qw(
|
||||
? ! a b d h i m o q r u
|
||||
autobundle
|
||||
bye
|
||||
clean
|
||||
cvs_import
|
||||
dump
|
||||
exit
|
||||
failed
|
||||
force
|
||||
fforce
|
||||
hosts
|
||||
install
|
||||
install_tested
|
||||
is_tested
|
||||
look
|
||||
ls
|
||||
make
|
||||
mkmyconfig
|
||||
notest
|
||||
perldoc
|
||||
quit
|
||||
readme
|
||||
recent
|
||||
recompile
|
||||
reload
|
||||
report
|
||||
reports
|
||||
scripts
|
||||
smoke
|
||||
test
|
||||
upgrade
|
||||
);
|
||||
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "5.5001";
|
||||
|
||||
package CPAN::Complete;
|
||||
use strict;
|
||||
|
||||
sub gnu_cpl {
|
||||
my($text, $line, $start, $end) = @_;
|
||||
my(@perlret) = cpl($text, $line, $start);
|
||||
# find longest common match. Can anybody show me how to peruse
|
||||
# T::R::Gnu to have this done automatically? Seems expensive.
|
||||
return () unless @perlret;
|
||||
my($newtext) = $text;
|
||||
for (my $i = length($text)+1;;$i++) {
|
||||
last unless length($perlret[0]) && length($perlret[0]) >= $i;
|
||||
my $try = substr($perlret[0],0,$i);
|
||||
my @tries = grep {substr($_,0,$i) eq $try} @perlret;
|
||||
# warn "try[$try]tries[@tries]";
|
||||
if (@tries == @perlret) {
|
||||
$newtext = $try;
|
||||
} else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
($newtext,@perlret);
|
||||
}
|
||||
|
||||
#-> sub CPAN::Complete::cpl ;
|
||||
sub cpl {
|
||||
my($word,$line,$pos) = @_;
|
||||
$word ||= "";
|
||||
$line ||= "";
|
||||
$pos ||= 0;
|
||||
CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
|
||||
$line =~ s/^\s*//;
|
||||
if ($line =~ s/^((?:notest|f?force)\s*)//) {
|
||||
$pos -= length($1);
|
||||
}
|
||||
my @return;
|
||||
if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
|
||||
@return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
|
||||
} elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
|
||||
@return = ();
|
||||
} elsif ($line =~ /^a\s/) {
|
||||
@return = cplx('CPAN::Author',uc($word));
|
||||
} elsif ($line =~ /^ls\s/) {
|
||||
my($author,$rest) = $word =~ m|([^/]+)/?(.*)|;
|
||||
@return = $rest ? () : map {"$_/"} cplx('CPAN::Author',uc($author||""));
|
||||
if (0 && 1==@return) { # XXX too slow and even wrong when there is a * already
|
||||
@return = grep /^\Q$word\E/, map {"$author/$_->[2]"} CPAN::Shell->expand("Author",$author)->ls("$rest*","2");
|
||||
}
|
||||
} elsif ($line =~ /^b\s/) {
|
||||
CPAN::Shell->local_bundles;
|
||||
@return = cplx('CPAN::Bundle',$word);
|
||||
} elsif ($line =~ /^d\s/) {
|
||||
@return = cplx('CPAN::Distribution',$word);
|
||||
} elsif ($line =~ m/^(
|
||||
[mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
|
||||
)\s/x ) {
|
||||
if ($word =~ /^Bundle::/) {
|
||||
CPAN::Shell->local_bundles;
|
||||
}
|
||||
@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
|
||||
} elsif ($line =~ /^i\s/) {
|
||||
@return = cpl_any($word);
|
||||
} elsif ($line =~ /^reload\s/) {
|
||||
@return = cpl_reload($word,$line,$pos);
|
||||
} elsif ($line =~ /^o\s/) {
|
||||
@return = cpl_option($word,$line,$pos);
|
||||
} elsif ($line =~ m/^\S+\s/ ) {
|
||||
# fallback for future commands and what we have forgotten above
|
||||
@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
|
||||
} else {
|
||||
@return = ();
|
||||
}
|
||||
return @return;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Complete::cplx ;
|
||||
sub cplx {
|
||||
my($class, $word) = @_;
|
||||
if (CPAN::_sqlite_running()) {
|
||||
$CPAN::SQLite->search($class, "^\Q$word\E");
|
||||
}
|
||||
my $method = "id";
|
||||
$method = "pretty_id" if $class eq "CPAN::Distribution";
|
||||
sort grep /^\Q$word\E/, map { $_->$method() } $CPAN::META->all_objects($class);
|
||||
}
|
||||
|
||||
#-> sub CPAN::Complete::cpl_any ;
|
||||
sub cpl_any {
|
||||
my($word) = shift;
|
||||
return (
|
||||
cplx('CPAN::Author',$word),
|
||||
cplx('CPAN::Bundle',$word),
|
||||
cplx('CPAN::Distribution',$word),
|
||||
cplx('CPAN::Module',$word),
|
||||
);
|
||||
}
|
||||
|
||||
#-> sub CPAN::Complete::cpl_reload ;
|
||||
sub cpl_reload {
|
||||
my($word,$line,$pos) = @_;
|
||||
$word ||= "";
|
||||
my(@words) = split " ", $line;
|
||||
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
|
||||
my(@ok) = qw(cpan index);
|
||||
return @ok if @words == 1;
|
||||
return grep /^\Q$word\E/, @ok if @words == 2 && $word;
|
||||
}
|
||||
|
||||
#-> sub CPAN::Complete::cpl_option ;
|
||||
sub cpl_option {
|
||||
my($word,$line,$pos) = @_;
|
||||
$word ||= "";
|
||||
my(@words) = split " ", $line;
|
||||
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
|
||||
my(@ok) = qw(conf debug);
|
||||
return @ok if @words == 1;
|
||||
return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
|
||||
if (0) {
|
||||
} elsif ($words[1] eq 'index') {
|
||||
return ();
|
||||
} elsif ($words[1] eq 'conf') {
|
||||
return CPAN::HandleConfig::cpl(@_);
|
||||
} elsif ($words[1] eq 'debug') {
|
||||
return sort grep /^\Q$word\E/i,
|
||||
sort keys %CPAN::DEBUG, 'all';
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
package CPAN::Debug;
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
$VERSION = "5.5001";
|
||||
# module is internal to CPAN.pm
|
||||
|
||||
%CPAN::DEBUG = qw[
|
||||
CPAN 1
|
||||
Index 2
|
||||
InfoObj 4
|
||||
Author 8
|
||||
Distribution 16
|
||||
Bundle 32
|
||||
Module 64
|
||||
CacheMgr 128
|
||||
Complete 256
|
||||
FTP 512
|
||||
Shell 1024
|
||||
Eval 2048
|
||||
HandleConfig 4096
|
||||
Tarzip 8192
|
||||
Version 16384
|
||||
Queue 32768
|
||||
FirstTime 65536
|
||||
];
|
||||
|
||||
$CPAN::DEBUG ||= 0;
|
||||
|
||||
#-> sub CPAN::Debug::debug ;
|
||||
sub debug {
|
||||
my($self,$arg) = @_;
|
||||
|
||||
my @caller;
|
||||
my $i = 0;
|
||||
while () {
|
||||
my(@c) = (caller($i))[0 .. ($i ? 3 : 2)];
|
||||
last unless defined $c[0];
|
||||
push @caller, \@c;
|
||||
for (0,3) {
|
||||
last if $_ > $#c;
|
||||
$c[$_] =~ s/.*:://;
|
||||
}
|
||||
for (1) {
|
||||
$c[$_] =~ s|.*/||;
|
||||
}
|
||||
last if ++$i>=3;
|
||||
}
|
||||
pop @caller;
|
||||
if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) {
|
||||
if ($arg and ref $arg) {
|
||||
eval { require Data::Dumper };
|
||||
if ($@) {
|
||||
$CPAN::Frontend->myprint("Debug(\n" . $arg->as_string . ")\n");
|
||||
} else {
|
||||
$CPAN::Frontend->myprint("Debug(\n" . Data::Dumper::Dumper($arg) . ")\n");
|
||||
}
|
||||
} else {
|
||||
my $outer = "";
|
||||
local $" = ",";
|
||||
if (@caller>1) {
|
||||
$outer = ",[@{$caller[1]}]";
|
||||
}
|
||||
$CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPAN::Debug - internal debugging for CPAN.pm
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
package CPAN::DeferredCode;
|
||||
|
||||
use strict;
|
||||
use vars qw/$VERSION/;
|
||||
|
||||
use overload fallback => 1, map { ($_ => 'run') } qw/
|
||||
bool "" 0+
|
||||
/;
|
||||
|
||||
$VERSION = "5.50";
|
||||
|
||||
sub run {
|
||||
$_[0]->();
|
||||
}
|
||||
|
||||
1;
|
||||
Разница между файлами не показана из-за своего большого размера
Загрузить разницу
|
|
@ -0,0 +1,481 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
package CPAN::Distroprefs;
|
||||
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '6.0001';
|
||||
|
||||
package CPAN::Distroprefs::Result;
|
||||
|
||||
use File::Spec;
|
||||
|
||||
sub new { bless $_[1] || {} => $_[0] }
|
||||
|
||||
sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
|
||||
|
||||
sub __cloner {
|
||||
my ($class, $name, $newclass) = @_;
|
||||
$newclass = 'CPAN::Distroprefs::Result::' . $newclass;
|
||||
no strict 'refs';
|
||||
*{$class . '::' . $name} = sub {
|
||||
$newclass->new({
|
||||
%{ $_[0] },
|
||||
%{ $_[1] },
|
||||
});
|
||||
};
|
||||
}
|
||||
BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
|
||||
BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
|
||||
BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
|
||||
|
||||
sub __accessor {
|
||||
my ($class, $key) = @_;
|
||||
no strict 'refs';
|
||||
*{$class . '::' . $key} = sub { $_[0]->{$key} };
|
||||
}
|
||||
BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
|
||||
|
||||
sub is_warning { 0 }
|
||||
sub is_fatal { 0 }
|
||||
sub is_success { 0 }
|
||||
|
||||
package CPAN::Distroprefs::Result::Error;
|
||||
use vars qw(@ISA);
|
||||
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
|
||||
BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
|
||||
|
||||
sub as_string {
|
||||
my ($self) = @_;
|
||||
if ($self->msg) {
|
||||
return sprintf $self->fmt_reason, $self->file, $self->msg;
|
||||
} else {
|
||||
return sprintf $self->fmt_unknown, $self->file;
|
||||
}
|
||||
}
|
||||
|
||||
package CPAN::Distroprefs::Result::Warning;
|
||||
use vars qw(@ISA);
|
||||
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
|
||||
sub is_warning { 1 }
|
||||
sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
|
||||
sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
|
||||
|
||||
package CPAN::Distroprefs::Result::Fatal;
|
||||
use vars qw(@ISA);
|
||||
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
|
||||
sub is_fatal { 1 }
|
||||
sub fmt_reason { "Error reading distroprefs file %s: %s" }
|
||||
sub fmt_unknown { "Unknown error reading distroprefs file %s." }
|
||||
|
||||
package CPAN::Distroprefs::Result::Success;
|
||||
use vars qw(@ISA);
|
||||
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
|
||||
BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
|
||||
sub is_success { 1 }
|
||||
|
||||
package CPAN::Distroprefs::Iterator;
|
||||
|
||||
sub new { bless $_[1] => $_[0] }
|
||||
|
||||
sub next { $_[0]->() }
|
||||
|
||||
package CPAN::Distroprefs;
|
||||
|
||||
use Carp ();
|
||||
use DirHandle;
|
||||
|
||||
sub _load_method {
|
||||
my ($self, $loader, $result) = @_;
|
||||
return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
|
||||
return '_load_' . $result->ext;
|
||||
}
|
||||
|
||||
sub _load_yaml {
|
||||
my ($self, $loader, $result) = @_;
|
||||
my $data = eval {
|
||||
$loader eq 'CPAN'
|
||||
? $loader->_yaml_loadfile($result->abs)
|
||||
: [ $loader->can('LoadFile')->($result->abs) ]
|
||||
};
|
||||
if (my $err = $@) {
|
||||
die $result->as_warning({
|
||||
msg => $err,
|
||||
});
|
||||
} elsif (!$data) {
|
||||
die $result->as_warning;
|
||||
} else {
|
||||
return @$data;
|
||||
}
|
||||
}
|
||||
|
||||
sub _load_dd {
|
||||
my ($self, $loader, $result) = @_;
|
||||
my @data;
|
||||
{
|
||||
package CPAN::Eval;
|
||||
# this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
|
||||
# not sure why we wouldn't just skip the file as we do for all other
|
||||
# errors. -- hdp
|
||||
my $abs = $result->abs;
|
||||
open FH, "<$abs" or die $result->as_fatal(msg => "$!");
|
||||
local $/;
|
||||
my $eval = <FH>;
|
||||
close FH;
|
||||
no strict;
|
||||
eval $eval;
|
||||
if (my $err = $@) {
|
||||
die $result->as_warning({ msg => $err });
|
||||
}
|
||||
my $i = 1;
|
||||
while (${"VAR$i"}) {
|
||||
push @data, ${"VAR$i"};
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
return @data;
|
||||
}
|
||||
|
||||
sub _load_st {
|
||||
my ($self, $loader, $result) = @_;
|
||||
# eval because Storable is never forward compatible
|
||||
my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
|
||||
if (my $err = $@) {
|
||||
die $result->as_warning({ msg => $err });
|
||||
}
|
||||
return @data;
|
||||
}
|
||||
|
||||
sub _build_file_list {
|
||||
if (@_ > 3) {
|
||||
die "_build_file_list should be called with 3 arguments, was called with more. First argument is '$_[0]'.";
|
||||
}
|
||||
my ($dir, $dir1, $ext_re) = @_;
|
||||
my @list;
|
||||
my $dh;
|
||||
unless (opendir($dh, $dir)) {
|
||||
$CPAN::Frontend->mywarn("ignoring prefs directory '$dir': $!");
|
||||
return @list;
|
||||
}
|
||||
while (my $fn = readdir $dh) {
|
||||
next if $fn eq '.' || $fn eq '..';
|
||||
if (-d "$dir/$fn") {
|
||||
next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
|
||||
push @list, _build_file_list("$dir/$fn", "$dir1$fn/", $ext_re);
|
||||
} else {
|
||||
if ($fn =~ $ext_re) {
|
||||
push @list, "$dir1$fn";
|
||||
}
|
||||
}
|
||||
}
|
||||
return @list;
|
||||
}
|
||||
|
||||
sub find {
|
||||
my ($self, $dir, $ext_map) = @_;
|
||||
|
||||
return CPAN::Distroprefs::Iterator->new(sub { return }) unless %$ext_map;
|
||||
|
||||
my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
|
||||
my $ext_re = qr/\.($possible_ext)$/;
|
||||
|
||||
my @files = _build_file_list($dir, '', $ext_re);
|
||||
@files = sort @files if @files;
|
||||
|
||||
# label the block so that we can use redo in the middle
|
||||
return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
|
||||
|
||||
my $fn = shift @files;
|
||||
return unless defined $fn;
|
||||
my ($ext) = $fn =~ $ext_re;
|
||||
|
||||
my $loader = $ext_map->{$ext};
|
||||
|
||||
my $result = CPAN::Distroprefs::Result->new({
|
||||
file => $fn, ext => $ext, dir => $dir
|
||||
});
|
||||
# copied from CPAN.pm; is this ever actually possible?
|
||||
redo unless -f $result->abs;
|
||||
|
||||
my $load_method = $self->_load_method($loader, $result);
|
||||
my @prefs = eval { $self->$load_method($loader, $result) };
|
||||
if (my $err = $@) {
|
||||
if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
|
||||
return $err;
|
||||
}
|
||||
# rethrow any exceptions that we did not generate
|
||||
die $err;
|
||||
} elsif (!@prefs) {
|
||||
# the loader should have handled this, but just in case:
|
||||
return $result->as_warning;
|
||||
}
|
||||
return $result->as_success({
|
||||
prefs => [
|
||||
map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
|
||||
],
|
||||
});
|
||||
} });
|
||||
}
|
||||
|
||||
package CPAN::Distroprefs::Pref;
|
||||
|
||||
use Carp ();
|
||||
|
||||
sub new { bless $_[1] => $_[0] }
|
||||
|
||||
sub data { shift->{data} }
|
||||
|
||||
sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
|
||||
|
||||
sub has_match {
|
||||
my $match = $_[0]->data->{match} || return 0;
|
||||
exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
|
||||
}
|
||||
|
||||
sub has_valid_subkeys {
|
||||
grep { exists $_[0]->data->{match}{$_} }
|
||||
map { $_, "not_$_" }
|
||||
$_[0]->match_attributes
|
||||
}
|
||||
|
||||
sub _pattern {
|
||||
my $re = shift;
|
||||
my $p = eval sprintf 'qr{%s}', $re;
|
||||
if ($@) {
|
||||
$@ =~ s/\n$//;
|
||||
die "Error in Distroprefs pattern qr{$re}\n$@";
|
||||
}
|
||||
return $p;
|
||||
}
|
||||
|
||||
sub _match_scalar {
|
||||
my ($match, $data) = @_;
|
||||
my $qr = _pattern($match);
|
||||
return $data =~ /$qr/;
|
||||
}
|
||||
|
||||
sub _match_hash {
|
||||
my ($match, $data) = @_;
|
||||
for my $mkey (keys %$match) {
|
||||
(my $dkey = $mkey) =~ s/^not_//;
|
||||
my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
|
||||
if (_match_scalar($match->{$mkey}, $val)) {
|
||||
return 0 if $mkey =~ /^not_/;
|
||||
}
|
||||
else {
|
||||
return 0 if $mkey !~ /^not_/;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _match {
|
||||
my ($self, $key, $data, $matcher) = @_;
|
||||
my $m = $self->data->{match};
|
||||
if (exists $m->{$key}) {
|
||||
return 0 unless $matcher->($m->{$key}, $data);
|
||||
}
|
||||
if (exists $m->{"not_$key"}) {
|
||||
return 0 if $matcher->($m->{"not_$key"}, $data);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _scalar_match {
|
||||
my ($self, $key, $data) = @_;
|
||||
return $self->_match($key, $data, \&_match_scalar);
|
||||
}
|
||||
|
||||
sub _hash_match {
|
||||
my ($self, $key, $data) = @_;
|
||||
return $self->_match($key, $data, \&_match_hash);
|
||||
}
|
||||
|
||||
# do not take the order of C<keys %$match> because "module" is by far the
|
||||
# slowest
|
||||
sub match_attributes { qw(env distribution perl perlconfig module) }
|
||||
|
||||
sub match_module {
|
||||
my ($self, $modules) = @_;
|
||||
return $self->_match("module", $modules, sub {
|
||||
my($match, $data) = @_;
|
||||
my $qr = _pattern($match);
|
||||
for my $module (@$data) {
|
||||
return 1 if $module =~ /$qr/;
|
||||
}
|
||||
return 0;
|
||||
});
|
||||
}
|
||||
|
||||
sub match_distribution { shift->_scalar_match(distribution => @_) }
|
||||
sub match_perl { shift->_scalar_match(perl => @_) }
|
||||
|
||||
sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
|
||||
sub match_env { shift->_hash_match(env => @_) }
|
||||
|
||||
sub matches {
|
||||
my ($self, $arg) = @_;
|
||||
|
||||
my $default_match = 0;
|
||||
for my $key (grep { $self->has_match($_) } $self->match_attributes) {
|
||||
unless (exists $arg->{$key}) {
|
||||
Carp::croak "Can't match pref: missing argument key $key";
|
||||
}
|
||||
$default_match = 1;
|
||||
my $val = $arg->{$key};
|
||||
# make it possible to avoid computing things until we have to
|
||||
if (ref($val) eq 'CODE') { $val = $val->() }
|
||||
my $meth = "match_$key";
|
||||
return 0 unless $self->$meth($val);
|
||||
}
|
||||
|
||||
return $default_match;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPAN::Distroprefs -- read and match distroprefs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use CPAN::Distroprefs;
|
||||
|
||||
my %info = (... distribution/environment info ...);
|
||||
|
||||
my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
|
||||
|
||||
while (my $result = $finder->next) {
|
||||
|
||||
die $result->as_string if $result->is_fatal;
|
||||
|
||||
warn($result->as_string), next if $result->is_warning;
|
||||
|
||||
for my $pref (@{ $result->prefs }) {
|
||||
if ($pref->matches(\%info)) {
|
||||
return $pref;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
|
||||
|
||||
=head1 INTERFACE
|
||||
|
||||
my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
|
||||
|
||||
while (my $result = $finder->next) { ... }
|
||||
|
||||
Build an iterator which finds distroprefs files in the tree below the
|
||||
given directory. Within the tree directories matching C<m/^[._]/> are
|
||||
pruned.
|
||||
|
||||
C<%ext_map> is a hashref whose keys are file extensions and whose values are
|
||||
modules used to load matching files:
|
||||
|
||||
{
|
||||
'yml' => 'YAML::Syck',
|
||||
'dd' => 'Data::Dumper',
|
||||
...
|
||||
}
|
||||
|
||||
Each time C<< $finder->next >> is called, the iterator returns one of two
|
||||
possible values:
|
||||
|
||||
=over
|
||||
|
||||
=item * a CPAN::Distroprefs::Result object
|
||||
|
||||
=item * C<undef>, indicating that no prefs files remain to be found
|
||||
|
||||
=back
|
||||
|
||||
=head1 RESULTS
|
||||
|
||||
L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
|
||||
indicate success or failure when reading a prefs file.
|
||||
|
||||
=head2 Common
|
||||
|
||||
All results share some common attributes:
|
||||
|
||||
=head3 type
|
||||
|
||||
C<success>, C<warning>, or C<fatal>
|
||||
|
||||
=head3 file
|
||||
|
||||
the file from which these prefs were read, or to which this error refers (relative filename)
|
||||
|
||||
=head3 ext
|
||||
|
||||
the file's extension, which determines how to load it
|
||||
|
||||
=head3 dir
|
||||
|
||||
the directory the file was read from
|
||||
|
||||
=head3 abs
|
||||
|
||||
the absolute path to the file
|
||||
|
||||
=head2 Errors
|
||||
|
||||
Error results (warning and fatal) contain:
|
||||
|
||||
=head3 msg
|
||||
|
||||
the error message (usually either C<$!> or a YAML error)
|
||||
|
||||
=head2 Successes
|
||||
|
||||
Success results contain:
|
||||
|
||||
=head3 prefs
|
||||
|
||||
an arrayref of CPAN::Distroprefs::Pref objects
|
||||
|
||||
=head1 PREFS
|
||||
|
||||
CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
|
||||
They are constructed automatically as part of C<success> results from C<find()>.
|
||||
|
||||
=head3 data
|
||||
|
||||
the pref information as a hashref, suitable for e.g. passing to Kwalify
|
||||
|
||||
=head3 match_attributes
|
||||
|
||||
returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
|
||||
|
||||
currently: C<env perl perlconfig distribution module>
|
||||
|
||||
=head3 has_any_match
|
||||
|
||||
true if this pref has a 'match' attribute at all
|
||||
|
||||
=head3 has_valid_subkeys
|
||||
|
||||
true if this pref has a 'match' attribute and at least one valid match attribute
|
||||
|
||||
=head3 matches
|
||||
|
||||
if ($pref->matches(\%arg)) { ... }
|
||||
|
||||
true if this pref matches the passed-in hashref, which must have a value for
|
||||
each of the C<match_attributes> (above)
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::Distrostatus;
|
||||
use overload '""' => "as_string",
|
||||
fallback => 1;
|
||||
use vars qw($something_has_failed_at);
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "5.5";
|
||||
|
||||
|
||||
sub new {
|
||||
my($class,$arg) = @_;
|
||||
my $failed = substr($arg,0,2) eq "NO";
|
||||
if ($failed) {
|
||||
$something_has_failed_at = $CPAN::CurrentCommandId;
|
||||
}
|
||||
bless {
|
||||
TEXT => $arg,
|
||||
FAILED => $failed,
|
||||
COMMANDID => $CPAN::CurrentCommandId,
|
||||
TIME => time,
|
||||
}, $class;
|
||||
}
|
||||
sub something_has_just_failed () {
|
||||
defined $something_has_failed_at &&
|
||||
$something_has_failed_at == $CPAN::CurrentCommandId;
|
||||
}
|
||||
sub commandid { shift->{COMMANDID} }
|
||||
sub failed { shift->{FAILED} }
|
||||
sub text {
|
||||
my($self,$set) = @_;
|
||||
if (defined $set) {
|
||||
$self->{TEXT} = $set;
|
||||
}
|
||||
$self->{TEXT};
|
||||
}
|
||||
sub as_string {
|
||||
my($self) = @_;
|
||||
$self->text;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::Exception::RecursiveDependency;
|
||||
use strict;
|
||||
use overload '""' => "as_string";
|
||||
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "5.5";
|
||||
|
||||
# a module sees its distribution (no version)
|
||||
# a distribution sees its prereqs (which are module names) (usually with versions)
|
||||
# a bundle sees its module names and/or its distributions (no version)
|
||||
|
||||
sub new {
|
||||
my($class) = shift;
|
||||
my($deps_arg) = shift;
|
||||
my (@deps,%seen,$loop_starts_with);
|
||||
DCHAIN: for my $dep (@$deps_arg) {
|
||||
push @deps, {name => $dep, display_as => $dep};
|
||||
if ($seen{$dep}++) {
|
||||
$loop_starts_with = $dep;
|
||||
last DCHAIN;
|
||||
}
|
||||
}
|
||||
my $in_loop = 0;
|
||||
for my $i (0..$#deps) {
|
||||
my $x = $deps[$i]{name};
|
||||
$in_loop ||= $loop_starts_with && $x eq $loop_starts_with;
|
||||
my $xo = CPAN::Shell->expandany($x) or next;
|
||||
if ($xo->isa("CPAN::Module")) {
|
||||
my $have = $xo->inst_version || "N/A";
|
||||
my($want,$d,$want_type);
|
||||
if ($i>0 and $d = $deps[$i-1]{name}) {
|
||||
my $do = CPAN::Shell->expandany($d);
|
||||
$want = $do->{prereq_pm}{requires}{$x};
|
||||
if (defined $want) {
|
||||
$want_type = "requires: ";
|
||||
} else {
|
||||
$want = $do->{prereq_pm}{build_requires}{$x};
|
||||
if (defined $want) {
|
||||
$want_type = "build_requires: ";
|
||||
} else {
|
||||
$want_type = "unknown status";
|
||||
$want = "???";
|
||||
}
|
||||
}
|
||||
} else {
|
||||
$want = $xo->cpan_version;
|
||||
$want_type = "want: ";
|
||||
}
|
||||
$deps[$i]{have} = $have;
|
||||
$deps[$i]{want_type} = $want_type;
|
||||
$deps[$i]{want} = $want;
|
||||
$deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
|
||||
} elsif ($xo->isa("CPAN::Distribution")) {
|
||||
$deps[$i]{display_as} = $xo->pretty_id;
|
||||
if ($in_loop) {
|
||||
$xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
|
||||
} else {
|
||||
$xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
|
||||
}
|
||||
$xo->store_persistent_state; # otherwise I will not reach
|
||||
# all involved parties for
|
||||
# the next session
|
||||
}
|
||||
}
|
||||
bless { deps => \@deps, loop_starts_with => $loop_starts_with }, $class;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
my($self) = shift;
|
||||
my $deps = $self->{deps};
|
||||
my $loop_starts_with = $self->{loop_starts_with};
|
||||
unless ($loop_starts_with) {
|
||||
return "--not a recursive/circular dependency--";
|
||||
}
|
||||
my $ret = "\nRecursive dependency detected:\n ";
|
||||
$ret .= join("\n => ", map {$_->{display_as}} @$deps);
|
||||
$ret .= ".\nCannot resolve.\n";
|
||||
$ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::Exception::blocked_urllist;
|
||||
use strict;
|
||||
use overload '""' => "as_string";
|
||||
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "1.001";
|
||||
|
||||
|
||||
sub new {
|
||||
my($class) = @_;
|
||||
bless {}, $class;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
my($self) = shift;
|
||||
if ($CPAN::Config->{connect_to_internet_ok}) {
|
||||
return qq{
|
||||
|
||||
You have not configured a urllist for CPAN mirrors. Configure it with
|
||||
|
||||
o conf init urllist
|
||||
|
||||
};
|
||||
} else {
|
||||
return qq{
|
||||
|
||||
You have not configured a urllist and do not allow connections to the
|
||||
internet to get a list of mirrors. If you wish to get a list of CPAN
|
||||
mirrors to pick from, use this command
|
||||
|
||||
o conf init connect_to_internet_ok urllist
|
||||
|
||||
If you do not wish to get a list of mirrors and would prefer to set
|
||||
your urllist manually, use just this command instead
|
||||
|
||||
o conf init urllist
|
||||
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
||||
# vim: ts=4 sts=4 sw=4:
|
||||
package CPAN::Exception::yaml_not_installed;
|
||||
use strict;
|
||||
use overload '""' => "as_string";
|
||||
|
||||
use vars qw(
|
||||
$VERSION
|
||||
);
|
||||
$VERSION = "5.5";
|
||||
|
||||
|
||||
sub new {
|
||||
my($class,$module,$file,$during) = @_;
|
||||
bless { module => $module, file => $file, during => $during }, $class;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
my($self) = shift;
|
||||
"'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
|
||||
}
|
||||
|
||||
1;
|
||||
Некоторые файлы не были показаны из-за слишком большого количества измененных файлов Показать больше
Загрузка…
Ссылка в новой задаче