AI-MaxEntropy
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
AI-MaxEntropy.xs view on Meta::CPAN
/**************************************************************************
* XS of AI:MaxEntropy
* -> by Laye Suen
**************************************************************************/
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
/* Macros for debugging */
/* uncomment the line below to enable tracing and timing */
/*#define __ENABLE_TRACING__*/
#ifdef __ENABLE_TRACING__
#include "time.h"
#define TRACE(msg) \
printf(_fn); printf(": "); printf(msg); \
printf(": %0.10f s\n", 1.0 * (clock() - _t) / CLOCKS_PER_SEC); \
fflush(stdout); _t = clock()
#define dTRACE(fn) clock_t _t = clock(); char* _fn = fn
#else
#define TRACE(msg)
#define dTRACE
#endif
/* Other macros */
#define hvref_fetch(hvref, key) \
hv_fetch((HV*)SvRV(hvref), key, strlen(key), 0)
#define hvref_exists(hvref, key) \
hv_exists((HV*)SvRV(hvref), key, strlen(key))
#define hvref_store(hvref, key, value) \
hv_store((HV*)SvRV(hvref), key, strlen(key), value, 0)
#define hvref_delete(hvref, key) \
hv_delete((HV*)SvRV(hvref), key, strlen(key), G_DISCARD)
/* internal structures */
struct samples_t {
int s_num;
int* x_len;
int** x;
int* y;
double* w;
};
struct f_map_t {
int y_num;
int** lambda_idx;
};
/**************************************************************************
* EXPORTED XSUBS
**************************************************************************/
MODULE = AI::MaxEntropy PACKAGE = AI::MaxEntropy
void
_neg_log_likelihood(lambda_in, step, self, OUTLIST SV* f, OUTLIST SV* g)
AV* lambda_in
SV* step
SV* self
PREINIT:
dTRACE("_neg_log_likelihood");
/* fetch the pre-cached samples and f_map */
SV* _c = *hvref_fetch(self, "_c");
struct samples_t* samples =
INT2PTR(struct samples_t*, SvIV(*hvref_fetch(_c, "samples")));
struct f_map_t* f_map =
INT2PTR(struct f_map_t*, SvIV(*hvref_fetch(_c, "f_map")));
int** lambda_idx = f_map->lambda_idx;
/* fetch other useful data */
SV* smoother = *hvref_fetch(self, "smoother");
int x_num = SvIV(*hvref_fetch(self, "x_num"));
int y_num = SvIV(*hvref_fetch(self, "y_num"));
int f_num = SvIV(*hvref_fetch(self, "f_num"));
/* intermediate variables */
AV* av_d_log_lh;
char* smoother_type;
int i, j, x, y, lambda_i;
double log_lh, sum_exp_lambda_f, sigma, fxy;
double* lambda_f = (double*)malloc(sizeof(double) * y_num);
double* exp_lambda_f = (double*)malloc(sizeof(double) * y_num);
double* d_log_lh = (double*)malloc(sizeof(double) * f_num);
double* lambda = (double*)malloc(sizeof(double) * f_num);
CODE:
/* initialize */
TRACE("enter");
for (i = 0; i < f_num; i++)
lambda[i] = SvNV(*av_fetch(lambda_in, i, 0));
log_lh = 0;
for (i = 0; i < f_num; i++) d_log_lh[i] = 0;
TRACE("finish initializing");
/* calculate log likelihood and its gradient */
for (i = 0; i < samples->s_num; i++) {
/* log likelihood */
for (sum_exp_lambda_f = 0, y = 0; y < y_num; y++) {
for (lambda_f[y] = 0, j = 0; j < samples->x_len[i]; j++) {
lambda_i = lambda_idx[y][samples->x[i][j]];
if (lambda_i != -1) lambda_f[y] += lambda[lambda_i];
}
sum_exp_lambda_f += (exp_lambda_f[y] = exp(lambda_f[y]));
}
log_lh += samples->w[i] *
(lambda_f[samples->y[i]] - log(sum_exp_lambda_f));
/* gradient */
for (y = 0; y < y_num; y++) {
fxy = (y == samples->y[i] ? 1.0 : 0.0);
for (j = 0; j < samples->x_len[i]; j++) {
lambda_i = lambda_idx[y][samples->x[i][j]];
if (lambda_i != -1)
d_log_lh[lambda_i] += samples->w[i] *
(fxy - exp_lambda_f[y] / sum_exp_lambda_f);
}
}
}
TRACE("finish log likelihood and gradient");
/* smoothing */
if (SvOK(smoother) && hvref_exists(smoother, "type")) {
smoother_type = SvPV_nolen(*hvref_fetch(smoother, "type"));
if (strcmp(smoother_type, "gaussian") == 0) {
sigma = SvOK(*hvref_fetch(smoother, "sigma")) ?
SvNV(*hvref_fetch(smoother, "sigma")) : 1.0;
for (i = 0; i < f_num; i++) {
log_lh -= (lambda[i] * lambda[i]) / (2 * sigma * sigma);
d_log_lh[i] -= lambda[i] / (sigma * sigma);
}
}
}
TRACE("finish smoothing");
/* negate the value and finish */
log_lh = -log_lh;
av_d_log_lh = newAV();
av_extend(av_d_log_lh, f_num - 1);
for (i = 0; i < f_num; i++)
av_store(av_d_log_lh, i, newSVnv(-d_log_lh[i]));
f = sv_2mortal(newSVnv(log_lh));
g = sv_2mortal(newRV_noinc((SV*)av_d_log_lh));
TRACE("leave");
CLEANUP:
free(lambda_f);
free(exp_lambda_f);
free(d_log_lh);
free(lambda);
SV*
_apply_gis(self, progress_cb, epsilon)
SV* self
SV* progress_cb
double epsilon
PREINIT:
dSP;
dTRACE("_apply_gis");
/* fetch the pre-cached samples and f_map */
SV* _c = *hvref_fetch(self, "_c");
struct samples_t* samples =
INT2PTR(struct samples_t*, SvIV(*hvref_fetch(_c, "samples")));
struct f_map_t* f_map =
INT2PTR(struct f_map_t*, SvIV(*hvref_fetch(_c, "f_map")));
int** lambda_idx = f_map->lambda_idx;
/* fetch other useful data */
AV* f_freq = (AV*)SvRV(*hvref_fetch(self, "f_freq"));
int x_num = SvIV(*hvref_fetch(self, "x_num"));
int y_num = SvIV(*hvref_fetch(self, "y_num"));
int f_num = SvIV(*hvref_fetch(self, "f_num"));
int af_num = SvIV(*hvref_fetch(self, "af_num"));
/* intermediate variables */
SV *sv_r;
AV *av_lambda, *av_d_lambda;
int i, j, k, y, lambda_i, r;
double sum_exp_lambda_f, pxy;
double d_lambda_norm, lambda_norm;
double* p_f = (double*)malloc(sizeof(double) * f_num);
double* p1_f = (double*)malloc(sizeof(double) * f_num);
double* lambda = (double*)malloc(sizeof(double) * f_num);
double* d_lambda = (double*)malloc(sizeof(double) * f_num);
double* exp_lambda_f = (double*)malloc(sizeof(double) * y_num);
CODE:
TRACE("enter");
/* initiate lambda */
for (i = 0; i < f_num; i++) lambda[i] = 0;
/* initiate p(f) */
for (j = 0; j < y_num; j++)
for (i = 0; i < x_num; i++) {
lambda_i = lambda_idx[j][i];
if (lambda_i != -1) p_f[lambda_i] = SvNV(
*av_fetch((AV*)SvRV(*av_fetch(f_freq, j, 0)), i, 0)) +
1e-5;
}
/* iterate */
k = 0;
do {
TRACE("iteration");
/* get p1(f) for current lambda */
for (i = 0; i < f_num; i++) p1_f[i] = 0;
for (i = 0; i < samples->s_num; i++) {
for (sum_exp_lambda_f = 0, y = 0; y < y_num; y++) {
for (exp_lambda_f[y] = 0, j = 0; j < af_num; j++) {
lambda_i = lambda_idx[y][samples->x[i][j]];
if (lambda_i != -1)
exp_lambda_f[y] += lambda[lambda_i];
}
exp_lambda_f[y] = exp(exp_lambda_f[y]);
sum_exp_lambda_f += exp_lambda_f[y];
}
for (y = 0; y < y_num; y++) {
pxy = exp_lambda_f[y] / sum_exp_lambda_f;
for (j = 0; j < af_num; j++) {
lambda_i = lambda_idx[y][samples->x[i][j]];
if (lambda_i != -1)
p1_f[lambda_i] += pxy * samples->w[i];
}
}
}
/* lambda = lambda + d_lambda */
d_lambda_norm = 0;
lambda_norm = 0;
for (i = 0; i < f_num; i++) {
d_lambda[i] = (1.0 / af_num) * log(p_f[i] / p1_f[i]);
lambda[i] += d_lambda[i];
d_lambda_norm += d_lambda[i] * d_lambda[i];
lambda_norm += lambda[i] * lambda[i];
}
d_lambda_norm = sqrt(d_lambda_norm);
lambda_norm = sqrt(lambda_norm);
/* call progress_cb if defined */
if (SvOK(progress_cb) && SvROK(progress_cb) &&
SvTYPE(SvRV(progress_cb)) == SVt_PVCV) {
TRACE("call progress_cb");
av_lambda = newAV();
av_d_lambda = newAV();
av_extend(av_lambda, f_num - 1);
av_extend(av_d_lambda, f_num - 1);
for (i = 0; i < f_num; i++) {
av_store(av_lambda, i, newSVnv(lambda[i]));
av_store(av_d_lambda, i, newSVnv(d_lambda[i]));
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSViv(k)));
XPUSHs(sv_2mortal(newRV_noinc((SV*)av_lambda)));
XPUSHs(sv_2mortal(newRV_noinc((SV*)av_d_lambda)));
XPUSHs(sv_2mortal(newSVnv(lambda_norm)));
XPUSHs(sv_2mortal(newSVnv(d_lambda_norm)));
PUTBACK;
call_sv(progress_cb, G_ARRAY);
SPAGAIN;
sv_r = POPs;
r = SvIV(sv_r);
PUTBACK;
FREETMPS;
LEAVE;
while (SvREFCNT(sv_r) > 0) { SvREFCNT_dec(sv_r); }
if (r != 0) break;
}
k++;
} while (d_lambda_norm > lambda_norm * epsilon);
/* finish */
av_lambda = newAV();
av_extend(av_lambda, f_num - 1);
for (i = 0; i < f_num; i++)
av_store(av_lambda, i, newSVnv(lambda[i]));
RETVAL = newRV_noinc((SV*)av_lambda);
TRACE("leave");
OUTPUT:
RETVAL
CLEANUP:
free(p_f);
free(p1_f);
free(lambda);
free(d_lambda);
free(exp_lambda_f);
void
_cache_samples(self)
SV* self
PREINIT:
SV* _c = *hvref_fetch(self, "_c");
AV* samples = (AV*)SvRV(*hvref_fetch(self, "samples"));
AV *sample, *x;
struct samples_t* ss =
(struct samples_t*)malloc(sizeof(struct samples_t));;
int i, j;
CODE:
ss->s_num = av_len(samples) + 1;
ss->x_len = (int*)malloc(sizeof(int) * ss->s_num);
ss->x = (int**)malloc(sizeof(int*) * ss->s_num);
ss->y = (int*)malloc(sizeof(int) * ss->s_num);
ss->w = (double*)malloc(sizeof(double) * ss->s_num);
for (i = 0; i < ss->s_num; i++) {
sample = (AV*)SvRV(*av_fetch(samples, i, 0));
x = (AV*)SvRV(*av_fetch(sample, 0, 0));
ss->x_len[i] = av_len(x) + 1;
ss->x[i] = (int*)malloc(sizeof(int) * ss->x_len[i]);
for (j = 0; j < ss->x_len[i]; j++)
ss->x[i][j] = SvIV(*av_fetch(x, j, 0));
ss->y[i] = SvIV(*av_fetch(sample, 1, 0));
ss->w[i] = SvNV(*av_fetch(sample, 2, 0));
}
hvref_store(_c, "samples", newSViv(PTR2IV(ss)));
void
_free_cache_samples(self)
SV* self
PREINIT:
SV* _c = *hvref_fetch(self, "_c");
struct samples_t* ss =
INT2PTR(struct samples_t*, SvIV(*hvref_fetch(_c, "samples")));
int i;
CODE:
free(ss->x_len);
for (i = 0; i < ss->s_num; i++) free(ss->x[i]);
free(ss->x);
free(ss->y);
free(ss->w);
free(ss);
hvref_delete(_c, "samples");
void
_cache_f_map(self)
SV* self
PREINIT:
SV* _c = *hvref_fetch(self, "_c");
AV* f_map = (AV*)SvRV(*hvref_fetch(self, "f_map"));
AV* f_map_y;
struct f_map_t* fm =
(struct f_map_t*)malloc(sizeof(struct f_map_t));;
int i, j, x_num;
CODE:
fm->y_num = av_len(f_map) + 1;
fm->lambda_idx = (int**)malloc(sizeof(int*) * fm->y_num);
for (j = 0; j < fm->y_num; j++) {
f_map_y = (AV*)SvRV(*av_fetch(f_map, j, 0));
x_num = av_len(f_map_y) + 1;
fm->lambda_idx[j] = (int*)malloc(sizeof(int) * x_num);
for (i = 0; i < x_num; i++)
fm->lambda_idx[j][i] = SvIV(*av_fetch(f_map_y, i, 0));
}
hvref_store(_c, "f_map", newSVuv(PTR2IV(fm)));
void
_free_cache_f_map(self)
SV* self
PREINIT:
SV* _c = *hvref_fetch(self, "_c");
struct f_map_t* fm =
INT2PTR(struct f_map_t*, SvIV(*hvref_fetch(_c, "f_map")));
int i;
CODE:
for (i = 0; i < fm->y_num; i++) free(fm->lambda_idx[i]);
free(fm->lambda_idx);
free(fm);
hvref_delete(_c, "f_map");
Revision history for Perl extension AI::MaxEntropy.
0.20 Thu Mar 6 20:20:00 2008
- Implemented GIS for ME model learning, now the client program can
any of the two algorithm (GIS and L-BFGS) for learning
- More optimization for speed
- $self->{optimizer} changed to $self->{algorithm}
- all_features changed to all_x
- Some modification on the documentation to avoid the ambiguity of
the concept 'feature'
0.11 Sat Feb 16 17:27:00 2008
- Optimize the XS code, now the the function 'learn' should run
at least twice faster than 0.10 version
- New functions in AI::MaxEntropy::Util, which allows the client
program manipulate samples more flexibly
- Replace Test::Differences with is_deeply in Test::More
0.10 Wed Feb 13 16:56:00 2008
- rewrite the log likelihood evaluation and smoothing by C, now
the ME learner should run more than 10 times faster than the
previous version
- add a new module AI::MaxEntropy::Util, which provides some
utilities for doing experiments with ME learners
- AI::MaxEntropy::see now accepts attribute-value style samples
- include Algorithm::Diff in the distribution for testing
0.02 Thu Feb 7 11:26:00 2008
- some tiny corrections :-P
0.01 Thu Feb 7 11:13:00 2008
- original version
The MIT License
Copyright (c) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
AI-MaxEntropy.xs
Changes
inc/Module/AutoInstall.pm
inc/Module/Install.pm
inc/Module/Install/AutoInstall.pm
inc/Module/Install/Base.pm
inc/Module/Install/Include.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/MakeMaker.pm
inc/Module/Install/Metadata.pm
inc/Test/Builder.pm
inc/Test/Builder/Module.pm
inc/Test/More.pm
inc/Test/Number/Delta.pm
lib/AI/MaxEntropy.pm
lib/AI/MaxEntropy/Model.pm
lib/AI/MaxEntropy/Util.pm
LICENSE
Makefile.PL
MANIFEST This list of files
META.yml
ppport.h
README
t/01-samples.t
t/02-learn_by_lbfgs.t
t/03-learn_by_gis.t
t/04-model.t
t/05-util.t
t/98-pod.t
---
abstract: Perl extension for learning Maximum Entropy Models
author:
- Laye Suen, <laye@cpan.org>
distribution_type: module
generated_by: Module::Install version 0.68
license: MIT
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
name: AI-MaxEntropy
no_index:
directory:
- inc
- t
requires:
Algorithm::LBFGS: 0.16
YAML::Syck: 0.87
version: 0.20
Makefile.PL view on Meta::CPAN
use strict;
use warnings;
use inc::Module::Install;
name 'AI-MaxEntropy';
all_from 'lib/AI/MaxEntropy.pm';
license 'MIT';
requires 'Algorithm::LBFGS' => '0.16';
requires 'YAML::Syck' => '0.87';
include 'Test::Builder';
include 'Test::Builder::Module';
include 'Test::More';
include 'Test::Number::Delta';
auto_install;
WriteMakefile(
LIBS => ['-lm'],
INC => '-I.',
OBJECT => '$(O_FILES)'
);
NAME
AI::MaxEntropy - Perl extension for learning Maximum Entropy Models
SYNOPSIS
use AI::MaxEntropy;
# create a maximum entropy learner
my $me = AI::MaxEntropy->new;
# the learner see 2 red round smooth apples
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
# the learner see 3 yellow long smooth bananas
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
# and more
# samples needn't have the same numbers of active features
$me->see(['rough', 'big'] => 'pomelo');
# the order of active features is not concerned, too
$me->see(['big', 'rough'] => 'pomelo');
# ...
# and, let it learn
my $model = $me->learn;
# then, we can make predictions on unseen data
# ask what a red thing is most likely to be
print $model->predict(['red'])."\n";
# the answer is apple, because all red things the learner have ever seen
# are apples
# ask what a smooth thing is most likely to be
print $model->predict(['smooth'])."\n";
# the answer is banana, because the learner have seen more smooth bananas
# (weighted 3) than smooth apples (weighted 2)
# ask what a red, long thing is most likely to be
print $model->predict(['red', 'long'])."\n";
# the answer is banana, because the learner have seen more long bananas
# (weighted 3) than red apples (weighted 2)
# print out scores of all possible answers to the feature round and red
for ($model->all_labels) {
my $s = $model->score(['round', 'red'] => $_);
print "$_: $s\n";
}
# save the model
$model->save('model_file');
# load the model
$model->load('model_file');
CONCEPTS
What is a Maximum Entropy model?
Maximum Entropy (ME) model is a popular approach for machine learning.
From a user's view, it just behaves like a classifier which classify
things according to the previously learnt things.
Theorically, a ME learner try to recover the real probability
distribution of the data based on limited number of observations, by
applying the principle of maximum entropy.
You can find some good tutorials on Maximum Entropy model here:
<http://homepages.inf.ed.ac.uk/s0450736/maxent.html>
Features
Generally, a feature is a binary function answers a yes-no question on a
specified piece of data.
For examples,
"Is it a red apple?"
"Is it a yellow banana?"
If the answer is yes, we say this feature is active on that piece of
data.
In practise, a feature is usually represented as a tuple "<x, y>". For
examples, the above two features can be represented as
<red, apple>
<yellow, banana>
Samples
A sample is a set of active features, all of which share a common "y".
This common "y" is sometimes called label or tag. For example, we have a
big round red apple, the correpsonding sample is
{<big, apple>, <round, apple>, <red, apple>}
In this module, a samples is denoted in Perl code as
$xs => $y => $w
$xs is an array ref holding all "x", $y is a scalar holding the label
and $w is the weight of the sample, which tells how many times the
sample occurs.
Therefore, the above sample can be denoted as
['big', 'round', 'red'] => 'apple' => 1.0
The weight $w can be ommited when it equals to 1.0, so the above
denotation can be shorten to
['big', 'round', 'red'] => 'apple'
Models
With a set of samples, a model can be learnt for future predictions. The
model (the lambda vector essentailly) is a knowledge representation of
the samples that it have seen before. By applying the model, we can
calculate the probability of each possible label for a certain sample.
And choose the most possible one according to these probabilities.
FUNCTIONS
NOTE: This is still an alpha version, the APIs may be changed in future
versions.
new
Create a Maximum Entropy learner. Optionally, initial values of
properties can be specified.
my $me1 = AI::MaxEntropy->new;
my $me2 = AI::MaxEntropy->new(
algorithm => { epsilon => 1e-6 });
my $me3 = AI::MaxEntropy->new(
algorithm => { m => 7, epsilon => 1e-4 },
smoother => { type => 'gaussian', sigma => 0.8 }
);
see
Let the Maximum Entropy learner see a sample.
my $me = AI::MaxEntropy->new;
# see a sample with default weight 1.0
$me->see(['red', 'round'] => 'apple');
# see a sample with specified weight 0.5
$me->see(['yellow', 'long'] => 'banana' => 0.5);
The sample can be also represented in the attribute-value form, which
like
$me->see({color => 'yellow', shape => 'long'} => 'banana');
$me->see({color => ['red', 'green'], shape => 'round'} => 'apple');
Actually, the two samples above are converted internally to,
$me->see(['color:yellow', 'shape:long'] => 'banana');
$me->see(['color:red', 'color:green', 'shape:round'] => 'apple');
forget_all
Forget all samples the learner have seen previously.
cut
Cut the features that occur less than the specified number.
For example,
...
$me->cut(1)
will cut all features that occur less than one time.
learn
Learn a model from all the samples that the learner have seen so far,
returns an AI::MaxEntropy::Model object, which can be used to make
prediction on unlabeled samples.
...
my $model = $me->learn;
print $model->predict(['x1', 'x2', ...]);
PROPERTIES
algorithm
This property enables client program to choose different algorithms for
learning the ME model and set their parameters.
There are mainly 3 algorithm for learning ME models, they are GIS, IIS
and L-BFGS. This module implements 2 of them, namely, L-BFGS and GIS.
L-BFGS provides full functionality, while GIS runs faster, but only
applicable on limited scenarios.
To use GIS, the following conditions must be satisified:
1. All samples have same number of active features
2. No feature has been cut
3. No smoother is used (in fact, the property "smoother" is simplly
ignored when the type of algorithm equal to 'gis').
This property "algorithm" is supposed to be a hash ref, like
{
type => ...,
progress_cb => ...,
param_1 => ...,
param_2 => ...,
...,
param_n => ...
}
type
The entry "type => ..." specifies which algorithm is used for the
optimization. Valid values include:
'lbfgs' Limited-memory Broyden-Fletcher-Goldfarb-Shanno (L-BFGS)
'gis' General Iterative Scaling (GIS)
If ommited, 'lbfgs' is used by default.
progress_cb
The entry "progress_cb => ..." specifies the progress callback
subroutine which is used to trace the process of the algorithm. The
specified callback routine will be called at each iteration of the
algorithm.
For L-BFGS, "progress_cb" will be directly passed to "fmin" in
Algorithm::LBFGS. f(x) is the negative log-likelihood of current lambda
vector.
For GIS, the "progress_cb" is supposed to have a prototype like
progress_cb(i, lambda, d_lambda, lambda_norm, d_lambda_norm)
"i" is the number of the iterations, "lambda" is an array ref containing
the current lambda vector, "d_lambda" is an array ref containing the
delta of the lambda vector in current iteration, "lambda_norm" and
"d_lambda_norm" are Euclid norms of "lambda" and "d_lambda"
respectively.
For both L-BFGS and GIS, the client program can also pass a string
'verbose' to "progress_cb" to use a default progress callback which
simply print out the progress on the screen.
"progress_cb" can also be omitted if the client program do not want to
trace the progress.
parameters
The rest entries are parameters for the specified algorithm. Each
parameter will be assigned with its default value when it is not given
explicitly.
For L-BFGS, the parameters will be directly passed to Algorithm::LBFGS
object, please refer to "Parameters" in Algorithm::LBFGS for details.
For GIS, there is only one parameter "epsilon", which controls the
precision of the algorithm (similar to the "epsilon" in
Algorithm::LBFGS). Generally speaking, a smaller "epsilon" produces a
more precise result. The default value of "epsilon" is 1e-3.
smoother
The smoother is a solution to the over-fitting problem. This property
chooses which type of smoother the client program want to apply and sets
the smoothing parameters.
Only one smoother have been implemented in this version of the module,
the Gaussian smoother.
One can apply the Gaussian smoother as following,
my $me = AI::MaxEntropy->new(
smoother => { type => 'gaussian', sigma => 0.6 }
);
The parameter "sigma" indicates the strength of smoothing. Usually,
sigma is a positive number no greater than 1.0. The strength of
smoothing grows as sigma getting close to 0.
SEE ALSO
AI::MaxEntropy::Model, AI::MaxEntropy::Util
Algorithm::LBFGS
Statistics::MaxEntropy, Algorithm::CRF, Algorithm::SVM, AI::DecisionTree
AUTHOR
Laye Suen, <laye@cpan.org>
COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
REFERENCE
A. L. Berge, V. J. Della Pietra, S. A. Della Pietra. A Maximum Entropy
Approach to Natural Language Processing, Computational Linguistics,
1996.
S. F. Chen, R. Rosenfeld. A Gaussian Prior for Smoothing Maximum Entropy
Models, February 1999 CMU-CS-99-108.
inc/Module/AutoInstall.pm view on Meta::CPAN
#line 1
package Module::AutoInstall;
use strict;
use Cwd ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.03';
}
# special map on pre-defined feature sets
my %FeatureMap = (
'' => 'Core Features', # XXX: deprecated
'-core' => 'Core Features',
);
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
my ( $PostambleActions, $PostambleUsed );
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
_init();
sub _accept_default {
$AcceptDefault = shift;
}
sub missing_modules {
return @Missing;
}
sub do_install {
__PACKAGE__->install(
[
$Config
? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
: ()
],
@Missing,
);
}
# initialize various flags, and/or perform install
sub _init {
foreach my $arg (
@ARGV,
split(
/[\s\t]+/,
$ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
)
)
{
if ( $arg =~ /^--config=(.*)$/ ) {
$Config = [ split( ',', $1 ) ];
}
elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
elsif ( $arg =~ /^--check(?:deps)?$/ ) {
$CheckOnly = 1;
}
elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
$SkipInstall = 1;
}
elsif ( $arg =~ /^--test(?:only)?$/ ) {
$TestOnly = 1;
}
}
}
# overrides MakeMaker's prompt() to automatically accept the default choice
sub _prompt {
goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
my ( $prompt, $default ) = @_;
my $y = ( $default =~ /^[Yy]/ );
print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
print "$default\n";
return $default;
}
# the workhorse
sub import {
my $class = shift;
my @args = @_ or return;
my $core_all;
print "*** $class version " . $class->VERSION . "\n";
print "*** Checking for Perl dependencies...\n";
my $cwd = Cwd::cwd();
$Config = [];
my $maxlen = length(
(
sort { length($b) <=> length($a) }
grep { /^[^\-]/ }
map {
ref($_)
? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
: ''
}
map { +{@args}->{$_} }
grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
)[0]
);
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
my $default = 1;
my $conflict = 0;
if ( $feature =~ m/^-(\w+)$/ ) {
my $option = lc($1);
# check for a newer version of myself
_update_to( $modules, @_ ) and return if $option eq 'version';
# sets CPAN configuration options
$Config = $modules if $option eq 'config';
# promote every features to core status
$core_all = ( $modules =~ /^all$/i ) and next
if $option eq 'core';
next unless $option eq 'core';
}
print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
$modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
unshift @$modules, -default => &{ shift(@$modules) }
if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
if ( $mod =~ m/^-(\w+)$/ ) {
my $option = lc($1);
$default = $arg if ( $option eq 'default' );
$conflict = $arg if ( $option eq 'conflict' );
@tests = @{$arg} if ( $option eq 'tests' );
@skiptests = @{$arg} if ( $option eq 'skiptests' );
next;
}
printf( "- %-${maxlen}s ...", $mod );
if ( $arg and $arg =~ /^\D/ ) {
unshift @$modules, $arg;
$arg = 0;
}
# XXX: check for conflicts and uninstalls(!) them.
if (
defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
push @required, $mod => $arg;
}
}
next unless @required;
my $mandatory = ( $feature eq '-core' or $core_all );
if (
!$SkipInstall
and (
$CheckOnly
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
. ( $mandatory ? ' mandatory' : ' optional' )
. qq{ module(s) from CPAN?},
$default ? 'y' : 'n',
) =~ /^[Yy]/
)
)
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
elsif ( !$SkipInstall
and $default
and $mandatory
and
_prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
=~ /^[Nn]/ )
{
push( @Missing, @required );
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
$DisabledTests{$_} = 1 for map { glob($_) } @tests;
}
}
$UnderCPAN = _check_lock(); # check for $UnderCPAN
if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
require Config;
print
"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
if eval '$>';
}
print "*** $class configuration finished.\n";
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
return unless @Missing;
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
print <<'END_MESSAGE';
*** Since we're running under CPANPLUS, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
_load_cpan();
# Find the CPAN lock-file
my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
return unless -f $lock;
# Check the lock
local *LOCK;
return unless open(LOCK, $lock);
if (
( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
) {
print <<'END_MESSAGE';
*** Since we're running under CPAN, I'll just let it take care
of the dependency's installation later.
END_MESSAGE
return 1;
}
close LOCK;
return;
}
sub install {
my $class = shift;
my $i; # used below to strip leading '-' from config keys
my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
my ( @modules, @installed );
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
if ( defined( _version_check( _load($pkg), $ver ) ) ) {
push @installed, $pkg;
}
else {
push @modules, $pkg, $ver;
}
}
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
print "*** Installing dependencies...\n";
return unless _connected_to('cpan.org');
my %args = @config;
my %failed;
local *FAILED;
if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
while (<FAILED>) { chomp; $failed{$_}++ }
close FAILED;
my @newmod;
while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
push @newmod, ( $k => $v ) unless $failed{$k};
}
@modules = @newmod;
}
if ( _has_cpanplus() ) {
_install_cpanplus( \@modules, \@config );
} else {
_install_cpan( \@modules, \@config );
}
print "*** $class installation finished.\n";
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
if ( defined( _version_check( _load($pkg), $ver ) ) ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
print FAILED "$pkg\n";
}
}
close FAILED if $args{do_once};
return @installed;
}
sub _install_cpanplus {
my @modules = @{ +shift };
my @config = _cpanplus_config( @{ +shift } );
my $installed = 0;
require CPANPLUS::Backend;
my $cp = CPANPLUS::Backend->new;
my $conf = $cp->configure_object;
return unless $conf->can('conf') # 0.05x+ with "sudo" support
or _can_write($conf->_get_build('base')); # 0.04x
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
my $makeflags = $conf->get_conf('makeflags') || '';
if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
# 0.03+ uses a hashref here
$makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
} else {
# 0.02 and below uses a scalar
$makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
}
$conf->set_conf( makeflags => $makeflags );
$conf->set_conf( prereqs => 1 );
while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
$conf->set_conf( $key, $val );
}
my $modtree = $cp->module_tree;
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
print "*** Installing $pkg...\n";
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
my $success;
my $obj = $modtree->{$pkg};
if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
}
my $rv = $cp->install( modules => [ $obj->{module} ] );
if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
print "*** $pkg successfully installed.\n";
$success = 1;
} else {
print "*** $pkg installation cancelled.\n";
$success = 0;
}
$installed += $success;
} else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
sub _cpanplus_config {
my @config = ();
while ( @_ ) {
my ($key, $value) = (shift(), shift());
if ( $key eq 'prerequisites_policy' ) {
if ( $value eq 'follow' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
} elsif ( $value eq 'ask' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_ASK();
} elsif ( $value eq 'ignore' ) {
$value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
} else {
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
}
} else {
die "*** Cannot convert option $key to CPANPLUS version.\n";
}
}
return @config;
}
sub _install_cpan {
my @modules = @{ +shift };
my @config = @{ +shift };
my $installed = 0;
my %args;
_load_cpan();
require Config;
if (CPAN->VERSION < 1.80) {
# no "sudo" support, probe for writableness
return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
and _can_write( $Config::Config{sitelib} );
}
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
my $makeflags = $CPAN::Config->{make_install_arg} || '';
$CPAN::Config->{make_install_arg} =
join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
# don't show start-up info
$CPAN::Config->{inhibit_startup_message} = 1;
# set additional options
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
( $args{$opt} = $arg, next )
if $opt =~ /^force$/; # pseudo-option
$CPAN::Config->{$opt} = $arg;
}
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
print "*** Installing $pkg...\n";
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
delete $INC{$inc};
}
my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
: CPAN::Shell->install($pkg);
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
if $CPAN::META;
};
if ( $rv eq 'YES' ) {
print "*** $pkg successfully installed.\n";
$success = 1;
}
else {
print "*** $pkg installation failed.\n";
$success = 0;
}
$installed += $success;
}
else {
print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
}
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
}
return $installed;
}
sub _has_cpanplus {
return (
$HasCPANPLUS = (
$INC{'CPANPLUS/Config.pm'}
or _load('CPANPLUS::Shell::Default')
)
);
}
# make guesses on whether we're under the CPAN installation directory
sub _under_cpan {
require Cwd;
require File::Spec;
my $cwd = File::Spec->canonpath( Cwd::cwd() );
my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
return ( index( $cwd, $cpan ) > -1 );
}
sub _update_to {
my $class = __PACKAGE__;
my $ver = shift;
return
if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
'y' ) =~ /^[Nn]/
)
{
die "*** Please install $class $ver manually.\n";
}
print << ".";
*** Trying to fetch it from CPAN...
.
# install ourselves
_load($class) and return $class->import(@_)
if $class->install( [], $class, $ver );
print << '.'; exit 1;
*** Cannot bootstrap myself. :-( Installation terminated.
.
}
# check if we're connected to some host, using inet_aton
sub _connected_to {
my $site = shift;
return (
( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
qq(
*** Your host cannot resolve the domain name '$site', which
probably means the Internet connections are unavailable.
==> Should we try to install the required module(s) anyway?), 'n'
) =~ /^[Yy]/
);
}
# check if a directory is writable; may create it on demand
sub _can_write {
my $path = shift;
mkdir( $path, 0755 ) unless -e $path;
return 1 if -w $path;
print << ".";
*** You are not allowed to write to the directory '$path';
the installation may fail due to insufficient permissions.
.
if (
eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
qq(
==> Should we try to re-execute the autoinstall process with 'sudo'?),
((-t STDIN) ? 'y' : 'n')
) =~ /^[Yy]/
)
{
# try to bootstrap ourselves from sudo
print << ".";
*** Trying to re-execute the autoinstall process with 'sudo'...
.
my $missing = join( ',', @Missing );
my $config = join( ',',
UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
return
unless system( 'sudo', $^X, $0, "--config=$config",
"--installdeps=$missing" );
print << ".";
*** The 'sudo' command exited with error! Resuming...
.
}
return _prompt(
qq(
==> Should we try to install the required module(s) anyway?), 'n'
) =~ /^[Yy]/;
}
# load a module and return the version it reports
sub _load {
my $mod = pop; # class/instance doesn't matter
my $file = $mod;
$file =~ s|::|/|g;
$file .= '.pm';
local $@;
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}
# Load CPAN.pm and it's configuration
sub _load_cpan {
return if $CPAN::VERSION;
require CPAN;
if ( $CPAN::HandleConfig::VERSION ) {
# Newer versions of CPAN have a HandleConfig module
CPAN::HandleConfig->load;
} else {
# Older versions had the load method in Config directly
CPAN::Config->load;
}
}
# compare two versions, either use Sort::Versions or plain comparison
sub _version_check {
my ( $cur, $min ) = @_;
return unless defined $cur;
$cur =~ s/\s+$//;
# check for version numbers that are not in decimal format
if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
if ( ( $version::VERSION or defined( _load('version') )) and
version->can('new')
) {
# use version.pm if it is installed.
return (
( version->new($cur) >= version->new($min) ) ? $cur : undef );
}
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
{
# use Sort::Versions as the sorting algorithm for a.b.c versions
return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
? $cur
: undef );
}
warn "Cannot reliably compare non-decimal formatted versions.\n"
. "Please install version.pm or Sort::Versions.\n";
}
# plain comparison
local $^W = 0; # shuts off 'not numeric' bugs
return ( $cur >= $min ? $cur : undef );
}
# nothing; this usage is deprecated.
sub main::PREREQ_PM { return {}; }
sub _make_args {
my %args = @_;
$args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
if $UnderCPAN or $TestOnly;
if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
require ExtUtils::Manifest;
my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
$args{EXE_FILES} =
[ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
}
$args{test}{TESTS} ||= 't/*.t';
$args{test}{TESTS} = join( ' ',
grep { !exists( $DisabledTests{$_} ) }
map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
my $missing = join( ',', @Missing );
my $config =
join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
if $Config;
$PostambleActions = (
$missing
? "\$(PERL) $0 --config=$config --installdeps=$missing"
: "\$(NOECHO) \$(NOOP)"
);
return %args;
}
# a wrapper to ExtUtils::MakeMaker::WriteMakefile
sub Write {
require Carp;
Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
if ($CheckOnly) {
print << ".";
*** Makefile not written in check-only mode.
.
return;
}
my %args = _make_args(@_);
no strict 'refs';
$PostambleUsed = 0;
local *MY::postamble = \&postamble unless defined &MY::postamble;
ExtUtils::MakeMaker::WriteMakefile(%args);
print << "." unless $PostambleUsed;
*** WARNING: Makefile written with customized MY::postamble() without
including contents from Module::AutoInstall::postamble() --
auto installation features disabled. Please contact the author.
.
return 1;
}
sub postamble {
$PostambleUsed = 1;
return << ".";
config :: installdeps
\t\$(NOECHO) \$(NOOP)
checkdeps ::
\t\$(PERL) $0 --checkdeps
installdeps ::
\t$PostambleActions
.
}
1;
__END__
#line 1003
inc/Module/Install.pm view on Meta::CPAN
#line 1
package Module::Install;
# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
# 3. The installed version of inc::Module::Install loads
# 4. inc::Module::Install calls "require Module::Install"
# 5. The ./inc/ version of Module::Install loads
# } ELSE {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
# 3. The ./inc/ version of Module::Install loads
# }
use 5.004;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '0.68';
}
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) {
die <<"END_DIE";
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
}
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 and (stat($0))[9] > time ) {
die << "END_DIE";
Your installer $0 has a modification time in the future.
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
unshift @_, ($self, $1);
goto &{$self->can('call')} unless uc($1) eq $1;
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
delete $INC{"$self->{path}.pm"};
}
sub preload {
my ($self) = @_;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
my $admin = $self->{admin};
@exts = $admin->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} = delete $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
my $in_pod = 0;
while ( <PKGFILE> ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
close PKGFILE;
}
push @found, [ $file, $pkg ];
}, $path ) if -d $path;
@found;
}
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
1;
inc/Module/Install/AutoInstall.pm view on Meta::CPAN
#line 1
package Module::Install::AutoInstall;
use strict;
use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub AutoInstall { $_[0] }
sub run {
my $self = shift;
$self->auto_install_now(@_);
}
sub write {
my $self = shift;
$self->auto_install(@_);
}
sub auto_install {
my $self = shift;
return if $self->{done}++;
# Flatten array of arrays into a single array
my @core = map @$_, map @$_, grep ref,
$self->build_requires, $self->requires;
my @config = @_;
# We'll need Module::AutoInstall
$self->include('Module::AutoInstall');
require Module::AutoInstall;
Module::AutoInstall->import(
(@config ? (-config => \@config) : ()),
(@core ? (-core => \@core) : ()),
$self->features,
);
$self->makemaker_args( Module::AutoInstall::_make_args() );
my $class = ref($self);
$self->postamble(
"# --- $class section:\n" .
Module::AutoInstall::postamble()
);
}
sub auto_install_now {
my $self = shift;
$self->auto_install(@_);
Module::AutoInstall::do_install();
}
1;
inc/Module/Install/Base.pm view on Meta::CPAN
#line 1
package Module::Install::Base;
$VERSION = '0.68';
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
### This is the ONLY module that shouldn't have strict on
# use strict;
#line 41
sub new {
my ($class, %args) = @_;
foreach my $method ( qw(call load) ) {
*{"$class\::$method"} = sub {
shift()->_top->$method(@_);
} unless defined &{"$class\::$method"};
}
bless( \%args, $class );
}
#line 61
sub AUTOLOAD {
my $self = shift;
local $@;
my $autoload = eval { $self->_top->autoload } or return;
goto &$autoload;
}
#line 76
sub _top { $_[0]->{_top} }
#line 89
sub admin {
$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
}
sub is_admin {
$_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
my $Fake;
sub new { $Fake ||= bless(\@_, $_[0]) }
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 138
inc/Module/Install/Include.pm view on Meta::CPAN
#line 1
package Module::Install::Include;
use strict;
use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub include {
shift()->admin->include(@_);
}
sub include_deps {
shift()->admin->include_deps(@_);
}
sub auto_include {
shift()->admin->auto_include(@_);
}
sub auto_include_deps {
shift()->admin->auto_include_deps(@_);
}
sub auto_include_dependent_dists {
shift()->admin->auto_include_dependent_dists(@_);
}
1;
inc/Module/Install/MakeMaker.pm view on Meta::CPAN
#line 1
package Module::Install::MakeMaker;
use strict;
use Module::Install::Base;
use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my $makefile;
sub WriteMakefile {
my ($self, %args) = @_;
$makefile = $self->load('Makefile');
# mapping between MakeMaker and META.yml keys
$args{MODULE_NAME} = $args{NAME};
unless ($args{NAME} = $args{DISTNAME} or !$args{MODULE_NAME}) {
$args{NAME} = $args{MODULE_NAME};
$args{NAME} =~ s/::/-/g;
}
foreach my $key (qw(name module_name version version_from abstract author installdirs)) {
my $value = delete($args{uc($key)}) or next;
$self->$key($value);
}
if (my $prereq = delete($args{PREREQ_PM})) {
while (my($k,$v) = each %$prereq) {
$self->requires($k,$v);
}
}
# put the remaining args to makemaker_args
$self->makemaker_args(%args);
}
END {
if ( $makefile ) {
$makefile->write;
$makefile->Meta->write;
}
}
1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
#line 1
package Module::Install::Makefile;
use strict 'vars';
use Module::Install::Base;
use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing, always use defaults
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
sub makemaker_args {
my $self = shift;
my $args = ($self->{makemaker_args} ||= {});
%$args = ( %$args, @_ ) if @_;
$args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
my $self = sShift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
? join( ' ', $args->{name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join(' ', grep length, $clean->{FILES}, @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join(' ', grep length, $realclean->{FILES}, @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
my %test_dir = ();
sub _wanted_t {
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
require File::Find;
%test_dir = ();
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
$args->{VERSION} = $self->version || $self->determine_VERSION($args);
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
if ($] >= 5.005) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
$args->{NO_META} = 1;
}
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
# merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
map { @$_ }
grep $_,
($self->build_requires, $self->requires)
);
# merge both kinds of requires into prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
delete $prereq->{$file};
}
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
$args->{INSTALLDIRS} = $self->installdirs;
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
$args{dist} = $preop;
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
my $makefile = do { local $/; <MAKEFILE> };
close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
#line 363
inc/Module/Install/Metadata.pm view on Meta::CPAN
#line 1
package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my @scalar_keys = qw{
name module_name abstract author version license
distribution_type perl_version tests installdirs
};
my @tuple_keys = qw{
build_requires requires recommends bundles
};
sub Meta { shift }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
foreach my $key (@scalar_keys) {
*$key = sub {
my $self = shift;
return $self->{values}{$key} if defined wantarray and !@_;
$self->{values}{$key} = shift;
return $self;
};
}
foreach my $key (@tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}{$key} unless @_;
my @rv;
while (@_) {
my $module = shift or last;
my $version = shift || 0;
if ( $module eq 'perl' ) {
$version =~ s{^(\d+)\.(\d+)\.(\d+)}
{$1 + $2/1_000 + $3/1_000_000}e;
$self->perl_version($version);
next;
}
my $rv = [ $module, $version ];
push @rv, $rv;
}
push @{ $self->{values}{$key} }, @rv;
@rv;
};
}
# configure_requires is currently a null-op
sub configure_requires { 1 }
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
my $self = shift;
return $self->{'values'}{'sign'} if defined wantarray and ! @_;
$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
return $self;
}
sub dynamic_config {
my $self = shift;
unless ( @_ ) {
warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
return $self;
}
$self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
return $self;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name
or die "all_from called with no args without setting name() first";
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
die "all_from: cannot find $file from $name" unless -e $file;
}
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
# The remaining probes read from POD sections; if the file
# has an accompanying .pod, use that instead
my $pod = $file;
if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
$file = $pod;
}
$self->author_from($file) unless $self->author;
$self->license_from($file) unless $self->license;
$self->abstract_from($file) unless $self->abstract;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides(%{ $build->find_dist_packages || {} });
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
: @$_
: $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}{no_index}{$type} }, @_ if $type;
return $self->{values}{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML', 0 );
require YAML;
my $data = YAML::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
}
else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
my ( $self, $file ) = @_;
require ExtUtils::MM_Unix;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
my ( $self, $file ) = @_;
require ExtUtils::MM_Unix;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
sub _slurp {
my ( $self, $file ) = @_;
local *FH;
open FH, "< $file" or die "Cannot open $file.pod: $!";
do { local $/; <FH> };
}
sub perl_version_from {
my ( $self, $file ) = @_;
if (
$self->_slurp($file) =~ m/
^
use \s*
v?
([\d_\.]+)
\s* ;
/ixms
)
{
my $v = $1;
$v =~ s{_}{}g;
$self->perl_version($1);
}
else {
warn "Cannot determine perl version info from $file\n";
return;
}
}
sub author_from {
my ( $self, $file ) = @_;
my $content = $self->_slurp($file);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
$author =~ s{E<lt>}{<}g;
$author =~ s{E<gt>}{>}g;
$self->author($author);
}
else {
warn "Cannot determine author info from $file\n";
}
}
sub license_from {
my ( $self, $file ) = @_;
if (
$self->_slurp($file) =~ m/
(
=head \d \s+
(?:licen[cs]e|licensing|copyright|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
\z
/ixms
)
{
my $license_text = $1;
my @phrases = (
'under the same (?:terms|license) as perl itself' => 'perl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser public license' => 'gpl', 1,
'BSD license' => 'bsd', 1,
'Artistic license' => 'artistic', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
if ( $osi and $license_text =~ /All rights reserved/i ) {
warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
}
$self->license($license);
return 1;
}
}
}
warn "Cannot determine license info from $file\n";
return 'unknown';
}
1;
inc/Test/Builder.pm view on Meta::CPAN
#line 1
package Test::Builder;
use 5.004;
# $^C was only introduced in 5.005-ish. We do this to prevent
# use of uninitialized value warnings in older perls.
$^C ||= 0;
use strict;
use vars qw($VERSION);
$VERSION = '0.72';
$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
BEGIN {
use Config;
# Load threads::shared when threads are turned on.
# 5.8.0's threads are so busted we no longer support them.
if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
# occassionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
my $data;
if( $type eq 'HASH' ) {
%$data = %{$_[0]};
}
elsif( $type eq 'ARRAY' ) {
@$data = @{$_[0]};
}
elsif( $type eq 'SCALAR' ) {
$$data = ${$_[0]};
}
else {
die("Unknown type: ".$type);
}
$_[0] = &threads::shared::share($_[0]);
if( $type eq 'HASH' ) {
%{$_[0]} = %$data;
}
elsif( $type eq 'ARRAY' ) {
@{$_[0]} = @$data;
}
elsif( $type eq 'SCALAR' ) {
${$_[0]} = $$data;
}
else {
die("Unknown type: ".$type);
}
return $_[0];
};
}
# 5.8.0's threads::shared is busted when threads are off
# and earlier Perls just don't have that module at all.
else {
*share = sub { return $_[0] };
*lock = sub { 0 };
}
}
#line 128
my $Test = Test::Builder->new;
sub new {
my($class) = shift;
$Test ||= $class->create;
return $Test;
}
#line 150
sub create {
my $class = shift;
my $self = bless {}, $class;
$self->reset;
return $self;
}
#line 169
use vars qw($Level);
sub reset {
my ($self) = @_;
# We leave this a global because it has to be localized and localizing
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
$self->{Test_Died} = 0;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Original_Pid} = $$;
share($self->{Curr_Test});
$self->{Curr_Test} = 0;
$self->{Test_Results} = &share([]);
$self->{Exported_To} = undef;
$self->{Expected_Tests} = 0;
$self->{Skip_All} = 0;
$self->{Use_Nums} = 1;
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
$self->_dup_stdhandles unless $^C;
return undef;
}
#line 221
sub exported_to {
my($self, $pack) = @_;
if( defined $pack ) {
$self->{Exported_To} = $pack;
}
return $self->{Exported_To};
}
#line 243
sub plan {
my($self, $cmd, $arg) = @_;
return unless $cmd;
local $Level = $Level + 1;
if( $self->{Have_Plan} ) {
$self->croak("You tried to plan twice");
}
if( $cmd eq 'no_plan' ) {
$self->no_plan;
}
elsif( $cmd eq 'skip_all' ) {
return $self->skip_all($arg);
}
elsif( $cmd eq 'tests' ) {
if( $arg ) {
local $Level = $Level + 1;
return $self->expected_tests($arg);
}
elsif( !defined $arg ) {
$self->croak("Got an undefined number of tests");
}
elsif( !$arg ) {
$self->croak("You said to run 0 tests");
}
}
else {
my @args = grep { defined } ($cmd, $arg);
$self->croak("plan() doesn't understand @args");
}
return 1;
}
#line 290
sub expected_tests {
my $self = shift;
my($max) = @_;
if( @_ ) {
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/ and $max > 0;
$self->{Expected_Tests} = $max;
$self->{Have_Plan} = 1;
$self->_print("1..$max\n") unless $self->no_header;
}
return $self->{Expected_Tests};
}
#line 315
sub no_plan {
my $self = shift;
$self->{No_Plan} = 1;
$self->{Have_Plan} = 1;
}
#line 330
sub has_plan {
my $self = shift;
return($self->{Expected_Tests}) if $self->{Expected_Tests};
return('no_plan') if $self->{No_Plan};
return(undef);
};
#line 348
sub skip_all {
my($self, $reason) = @_;
my $out = "1..0";
$out .= " # Skip $reason" if $reason;
$out .= "\n";
$self->{Skip_All} = 1;
$self->_print($out) unless $self->no_header;
exit(0);
}
#line 382
sub ok {
my($self, $test, $name) = @_;
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
$self->_plan_check;
lock $self->{Curr_Test};
$self->{Curr_Test}++;
# In case $name is a string overloaded object, force it to stringify.
$self->_unoverload_str(\$name);
$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
ERR
my($pack, $file, $line) = $self->caller;
my $todo = $self->todo($pack);
$self->_unoverload_str(\$todo);
my $out;
my $result = &share({});
unless( $test ) {
$out .= "not ";
@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
}
else {
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
}
$out .= "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
if( defined $name ) {
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
$out .= " - $name";
$result->{name} = $name;
}
else {
$result->{name} = '';
}
if( $todo ) {
$out .= " # TODO $todo";
$result->{reason} = $todo;
$result->{type} = 'todo';
}
else {
$result->{reason} = '';
$result->{type} = '';
}
$self->{Test_Results}[$self->{Curr_Test}-1] = $result;
$out .= "\n";
$self->_print($out);
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
if( defined $name ) {
$self->diag(qq[ $msg test '$name'\n]);
$self->diag(qq[ at $file line $line.\n]);
}
else {
$self->diag(qq[ $msg test at $file line $line.\n]);
}
}
return $test ? 1 : 0;
}
sub _unoverload {
my $self = shift;
my $type = shift;
$self->_try(sub { require overload } ) || return;
foreach my $thing (@_) {
if( $self->_is_object($$thing) ) {
if( my $string_meth = overload::Method($$thing, $type) ) {
$$thing = $$thing->$string_meth();
}
}
}
}
sub _is_object {
my($self, $thing) = @_;
return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
}
sub _unoverload_str {
my $self = shift;
$self->_unoverload(q[""], @_);
}
sub _unoverload_num {
my $self = shift;
$self->_unoverload('0+', @_);
for my $val (@_) {
next unless $self->_is_dualvar($$val);
$$val = $$val+0;
}
}
# This is a hack to detect a dualvar such as $!
sub _is_dualvar {
my($self, $val) = @_;
local $^W = 0;
my $numval = $val+0;
return 1 if $numval != 0 and $numval ne $val;
}
#line 530
sub is_eq {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_str(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, 'eq', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'eq', $expect, $name);
}
sub is_num {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_num(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, '==', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '==', $expect, $name);
}
sub _is_diag {
my($self, $got, $type, $expect) = @_;
foreach my $val (\$got, \$expect) {
if( defined $$val ) {
if( $type eq 'eq' ) {
# quote and force string context
$$val = "'$$val'"
}
else {
# force numeric context
$self->_unoverload_num($val);
}
}
else {
$$val = 'undef';
}
}
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
#line 608
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'ne', $dont_expect, $name);
}
sub isnt_num {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, '!=', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '!=', $dont_expect, $name);
}
#line 660
sub like {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '=~', $name);
}
sub unlike {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '!~', $name);
}
#line 685
my %numeric_cmps = map { ($_, 1) }
("<", "<=", ">", ">=", "==", "!=", "<=>");
sub cmp_ok {
my($self, $got, $type, $expect, $name) = @_;
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
: '_unoverload_str';
$self->$unoverload(\$got, \$expect);
my $test;
{
local($@,$!,$SIG{__DIE__}); # isolate eval
my $code = $self->_caller_context;
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . "\$got $type \$expect;";
}
local $Level = $Level + 1;
my $ok = $self->ok($test, $name);
unless( $ok ) {
if( $type =~ /^(eq|==)$/ ) {
$self->_is_diag($got, $type, $expect);
}
else {
$self->_cmp_diag($got, $type, $expect);
}
}
return $ok;
}
sub _cmp_diag {
my($self, $got, $type, $expect) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub _caller_context {
my $self = shift;
my($pack, $file, $line) = $self->caller(1);
my $code = '';
$code .= "#line $line $file\n" if defined $file and defined $line;
return $code;
}
#line 771
sub BAIL_OUT {
my($self, $reason) = @_;
$self->{Bailed_Out} = 1;
$self->_print("Bail out! $reason");
exit 255;
}
#line 784
*BAILOUT = \&BAIL_OUT;
#line 796
sub skip {
my($self, $why) = @_;
$why ||= '';
$self->_unoverload_str(\$why);
$self->_plan_check;
lock($self->{Curr_Test});
$self->{Curr_Test}++;
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
'ok' => 1,
actual_ok => 1,
name => '',
type => 'skip',
reason => $why,
});
my $out = "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # skip";
$out .= " $why" if length $why;
$out .= "\n";
$self->_print($out);
return 1;
}
#line 838
sub todo_skip {
my($self, $why) = @_;
$why ||= '';
$self->_plan_check;
lock($self->{Curr_Test});
$self->{Curr_Test}++;
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
'ok' => 1,
actual_ok => 0,
name => '',
type => 'todo_skip',
reason => $why,
});
my $out = "not ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # TODO & SKIP $why\n";
$self->_print($out);
return 1;
}
#line 916
sub maybe_regex {
my ($self, $regex) = @_;
my $usable_regex = undef;
return $usable_regex unless defined $regex;
my($re, $opts);
# Check for qr/foo/
if( ref $regex eq 'Regexp' ) {
$usable_regex = $regex;
}
# Check for '/foo/' or 'm,foo,'
elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
(undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
)
{
$usable_regex = length $opts ? "(?$opts)$re" : $re;
}
return $usable_regex;
};
sub _regex_ok {
my($self, $this, $regex, $cmp, $name) = @_;
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
unless (defined $usable_regex) {
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
{
my $test;
my $code = $self->_caller_context;
local($@, $!, $SIG{__DIE__}); # isolate eval
# Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
$test = !$test if $cmp eq '!~';
local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
DIAGNOSTIC
}
return $ok;
}
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
#line 1000
sub _try {
my($self, $code) = @_;
local $!; # eval can mess up $!
local $@; # don't set $@ in the test
local $SIG{__DIE__}; # don't trip an outside DIE handler.
my $return = eval { $code->() };
return wantarray ? ($return, $@) : $return;
}
#line 1022
sub is_fh {
my $self = shift;
my $maybe_fh = shift;
return 0 unless defined $maybe_fh;
return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
return eval { $maybe_fh->isa("IO::Handle") } ||
# 5.5.4's tied() and can() doesn't like getting undef
eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
}
#line 1067
sub level {
my($self, $level) = @_;
if( defined $level ) {
$Level = $level;
}
return $Level;
}
#line 1100
sub use_numbers {
my($self, $use_nums) = @_;
if( defined $use_nums ) {
$self->{Use_Nums} = $use_nums;
}
return $self->{Use_Nums};
}
#line 1134
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
my $code = sub {
my($self, $no) = @_;
if( defined $no ) {
$self->{$attribute} = $no;
}
return $self->{$attribute};
};
no strict 'refs';
*{__PACKAGE__.'::'.$method} = $code;
}
#line 1188
sub diag {
my($self, @msgs) = @_;
return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Smash args together like print does.
# Convert undef to 'undef' so its readable.
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
# Escape each line with a #.
$msg =~ s/^/# /gm;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
local $Level = $Level + 1;
$self->_print_diag($msg);
return 0;
}
#line 1225
sub _print {
my($self, @msgs) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
my $msg = join '', @msgs;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->output;
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
$msg =~ s/\n(.)/\n# $1/sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
print $fh $msg;
}
#line 1259
sub _print_diag {
my $self = shift;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
print $fh @_;
}
#line 1296
sub output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Out_FH} = $self->_new_fh($fh);
}
return $self->{Out_FH};
}
sub failure_output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Fail_FH} = $self->_new_fh($fh);
}
return $self->{Fail_FH};
}
sub todo_output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Todo_FH} = $self->_new_fh($fh);
}
return $self->{Todo_FH};
}
sub _new_fh {
my $self = shift;
my($file_or_fh) = shift;
my $fh;
if( $self->is_fh($file_or_fh) ) {
$fh = $file_or_fh;
}
else {
$fh = do { local *FH };
open $fh, ">$file_or_fh" or
$self->croak("Can't open test output log $file_or_fh: $!");
_autoflush($fh);
}
return $fh;
}
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
}
sub _dup_stdhandles {
my $self = shift;
$self->_open_testhandles;
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
_autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
_autoflush(\*TESTERR);
_autoflush(\*STDERR);
$self->output(\*TESTOUT);
$self->failure_output(\*TESTERR);
$self->todo_output(\*TESTOUT);
}
my $Opened_Testhandles = 0;
sub _open_testhandles {
return if $Opened_Testhandles;
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
$Opened_Testhandles = 1;
}
#line 1396
sub _message_at_caller {
my $self = shift;
local $Level = $Level + 1;
my($pack, $file, $line) = $self->caller;
return join("", @_) . " at $file line $line.\n";
}
sub carp {
my $self = shift;
warn $self->_message_at_caller(@_);
}
sub croak {
my $self = shift;
die $self->_message_at_caller(@_);
}
sub _plan_check {
my $self = shift;
unless( $self->{Have_Plan} ) {
local $Level = $Level + 2;
$self->croak("You tried to run a test without a plan");
}
}
#line 1444
sub current_test {
my($self, $num) = @_;
lock($self->{Curr_Test});
if( defined $num ) {
unless( $self->{Have_Plan} ) {
$self->croak("Can't change the current test number without a plan!");
}
$self->{Curr_Test} = $num;
# If the test counter is being pushed forward fill in the details.
my $test_results = $self->{Test_Results};
if( $num > @$test_results ) {
my $start = @$test_results ? @$test_results : 0;
for ($start..$num-1) {
$test_results->[$_] = &share({
'ok' => 1,
actual_ok => undef,
reason => 'incrementing test number',
type => 'unknown',
name => undef
});
}
}
# If backward, wipe history. Its their funeral.
elsif( $num < @$test_results ) {
$#{$test_results} = $num - 1;
}
}
return $self->{Curr_Test};
}
#line 1489
sub summary {
my($self) = shift;
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
#line 1544
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
#line 1569
sub todo {
my($self, $pack) = @_;
$pack = $pack || $self->exported_to || $self->caller($Level);
return 0 unless $pack;
no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
#line 1590
sub caller {
my($self, $height) = @_;
$height ||= 0;
my @caller = CORE::caller($self->level + $height + 1);
return wantarray ? @caller : $caller[0];
}
#line 1602
#line 1616
#'#
sub _sanity_check {
my $self = shift;
$self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
$self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
'Somehow your tests ran without a plan!');
$self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
'Somehow you got a different number of results than tests ran!');
}
#line 1637
sub _whoa {
my($self, $check, $desc) = @_;
if( $check ) {
local $Level = $Level + 1;
$self->croak(<<"WHOA");
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
#line 1659
sub _my_exit {
$? = $_[0];
return 1;
}
#line 1672
$SIG{__DIE__} = sub {
# We don't want to muck with death in an eval, but $^S isn't
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
# with it. Instead, we use caller. This also means it runs under
# 5.004!
my $in_eval = 0;
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
$in_eval = 1 if $sub =~ /^\(eval\)/;
}
$Test->{Test_Died} = 1 unless $in_eval;
};
sub _ending {
my $self = shift;
$self->_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
# Don't do an ending if we bailed out.
if( ($self->{Original_Pid} != $$) or
(!$self->{Have_Plan} && !$self->{Test_Died}) or
$self->{Bailed_Out}
)
{
_my_exit($?);
return;
}
# Figure out if we passed or failed and print helpful messages.
my $test_results = $self->{Test_Results};
if( @$test_results ) {
# The plan? We have no plan.
if( $self->{No_Plan} ) {
$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
$self->{Expected_Tests} = $self->{Curr_Test};
}
# Auto-extended arrays and elements which aren't explicitly
# filled in with a shared reference will puke under 5.8.0
# ithreads. So we have to fill them in by hand. :(
my $empty_result = &share({});
for my $idx ( 0..$self->{Expected_Tests}-1 ) {
$test_results->[$idx] = $empty_result
unless defined $test_results->[$idx];
}
my $num_failed = grep !$_->{'ok'},
@{$test_results}[0..$self->{Curr_Test}-1];
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
if( $num_extra < 0 ) {
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
FAIL
}
elsif( $num_extra > 0 ) {
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
FAIL
}
if ( $num_failed ) {
my $num_tests = $self->{Curr_Test};
my $s = $num_failed == 1 ? '' : 's';
my $qualifier = $num_extra == 0 ? '' : ' run';
$self->diag(<<"FAIL");
Looks like you failed $num_failed test$s of $num_tests$qualifier.
FAIL
}
if( $self->{Test_Died} ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
_my_exit( 255 ) && return;
}
my $exit_code;
if( $num_failed ) {
$exit_code = $num_failed <= 254 ? $num_failed : 254;
}
elsif( $num_extra != 0 ) {
$exit_code = 255;
}
else {
$exit_code = 0;
}
_my_exit( $exit_code ) && return;
}
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
}
elsif ( $self->{Test_Died} ) {
$self->diag(<<'FAIL');
Looks like your test died before it could output anything.
FAIL
_my_exit( 255 ) && return;
}
else {
$self->diag("No tests run!\n");
_my_exit( 255 ) && return;
}
}
END {
$Test->_ending if defined $Test and !$Test->no_ending;
}
#line 1847
1;
inc/Test/Builder/Module.pm view on Meta::CPAN
#line 1
package Test::Builder::Module;
use Test::Builder;
require Exporter;
@ISA = qw(Exporter);
$VERSION = '0.72';
use strict;
# 5.004's Exporter doesn't have export_to_level.
my $_export_to_level = sub {
my $pkg = shift;
my $level = shift;
(undef) = shift; # redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
};
#line 82
sub import {
my($class) = shift;
my $test = $class->builder;
my $caller = caller;
$test->exported_to($caller);
$class->import_extra(\@_);
my(@imports) = $class->_strip_imports(\@_);
$test->plan(@_);
$class->$_export_to_level(1, $class, @imports);
}
sub _strip_imports {
my $class = shift;
my $list = shift;
my @imports = ();
my @other = ();
my $idx = 0;
while( $idx <= $#{$list} ) {
my $item = $list->[$idx];
if( defined $item and $item eq 'import' ) {
push @imports, @{$list->[$idx+1]};
$idx++;
}
else {
push @other, $item;
}
$idx++;
}
@$list = @other;
return @imports;
}
#line 144
sub import_extra {}
#line 175
sub builder {
return Test::Builder->new;
}
1;
inc/Test/More.pm view on Meta::CPAN
#line 1
package Test::More;
use 5.004;
use strict;
# Can't use Carp because it might cause use_ok() to accidentally succeed
# even though the module being used forgot to use Carp. Yes, this
# actually happened.
sub _carp {
my($file, $line) = (caller(1))[1,2];
warn @_, " at $file line $line\n";
}
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
$VERSION = '0.72';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@ISA = qw(Test::Builder::Module);
@EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
cmp_ok
skip todo todo_skip
pass fail
eq_array eq_hash eq_set
$TODO
plan
can_ok isa_ok
diag
BAIL_OUT
);
#line 157
sub plan {
my $tb = Test::More->builder;
$tb->plan(@_);
}
# This implements "use Test::More 'no_diag'" but the behavior is
# deprecated.
sub import_extra {
my $class = shift;
my $list = shift;
my @other = ();
my $idx = 0;
while( $idx <= $#{$list} ) {
my $item = $list->[$idx];
if( defined $item and $item eq 'no_diag' ) {
$class->builder->no_diag(1);
}
else {
push @other, $item;
}
$idx++;
}
@$list = @other;
}
#line 257
sub ok ($;$) {
my($test, $name) = @_;
my $tb = Test::More->builder;
$tb->ok($test, $name);
}
#line 324
sub is ($$;$) {
my $tb = Test::More->builder;
$tb->is_eq(@_);
}
sub isnt ($$;$) {
my $tb = Test::More->builder;
$tb->isnt_eq(@_);
}
*isn't = \&isnt;
#line 369
sub like ($$;$) {
my $tb = Test::More->builder;
$tb->like(@_);
}
#line 385
sub unlike ($$;$) {
my $tb = Test::More->builder;
$tb->unlike(@_);
}
#line 425
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
$tb->cmp_ok(@_);
}
#line 461
sub can_ok ($@) {
my($proto, @methods) = @_;
my $class = ref $proto || $proto;
my $tb = Test::More->builder;
unless( $class ) {
my $ok = $tb->ok( 0, "->can(...)" );
$tb->diag(' can_ok() called with empty class or reference');
return $ok;
}
unless( @methods ) {
my $ok = $tb->ok( 0, "$class->can(...)" );
$tb->diag(' can_ok() called with no methods');
return $ok;
}
my @nok = ();
foreach my $method (@methods) {
$tb->_try(sub { $proto->can($method) }) or push @nok, $method;
}
my $name;
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
my $ok = $tb->ok( !@nok, $name );
$tb->diag(map " $class->can('$_') failed\n", @nok);
return $ok;
}
#line 523
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
my $tb = Test::More->builder;
my $diag;
$obj_name = 'The object' unless defined $obj_name;
my $name = "$obj_name isa $class";
if( !defined $object ) {
$diag = "$obj_name isn't defined";
}
elsif( !ref $object ) {
$diag = "$obj_name isn't a reference";
}
else {
# We can't use UNIVERSAL::isa because we want to honor isa() overrides
my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
if( $error ) {
if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
# Its an unblessed reference
if( !UNIVERSAL::isa($object, $class) ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
} else {
die <<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
Here's the error.
$error
WHOA
}
}
elsif( !$rslt ) {
my $ref = ref $object;
$diag = "$obj_name isn't a '$class' it's a '$ref'";
}
}
my $ok;
if( $diag ) {
$ok = $tb->ok( 0, $name );
$tb->diag(" $diag\n");
}
else {
$ok = $tb->ok( 1, $name );
}
return $ok;
}
#line 592
sub pass (;$) {
my $tb = Test::More->builder;
$tb->ok(1, @_);
}
sub fail (;$) {
my $tb = Test::More->builder;
$tb->ok(0, @_);
}
#line 653
sub use_ok ($;@) {
my($module, @imports) = @_;
@imports = () unless @imports;
my $tb = Test::More->builder;
my($pack,$filename,$line) = caller;
local($@,$!,$SIG{__DIE__}); # isolate eval
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
# probably a version check. Perl needs to see the bare number
# for it to work with non-Exporter based modules.
eval <<USE;
package $pack;
use $module $imports[0];
USE
}
else {
eval <<USE;
package $pack;
use $module \@imports;
USE
}
my $ok = $tb->ok( !$@, "use $module;" );
unless( $ok ) {
chomp $@;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
{BEGIN failed--compilation aborted at $filename line $line.}m;
$tb->diag(<<DIAGNOSTIC);
Tried to use '$module'.
Error: $@
DIAGNOSTIC
}
return $ok;
}
#line 702
sub require_ok ($) {
my($module) = shift;
my $tb = Test::More->builder;
my $pack = caller;
# Try to deterine if we've been given a module name or file.
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
local($!, $@, $SIG{__DIE__}); # isolate eval
local $SIG{__DIE__};
eval <<REQUIRE;
package $pack;
require $module;
REQUIRE
my $ok = $tb->ok( !$@, "require $module;" );
unless( $ok ) {
chomp $@;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
Error: $@
DIAGNOSTIC
}
return $ok;
}
sub _is_module_name {
my $module = shift;
# Module names start with a letter.
# End with an alphanumeric.
# The rest is an alphanumeric or ::
$module =~ s/\b::\b//g;
$module =~ /^[a-zA-Z]\w*$/;
}
#line 779
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
sub _dne {
ref $_[0] eq ref $DNE;
}
sub is_deeply {
my $tb = Test::More->builder;
unless( @_ == 2 or @_ == 3 ) {
my $msg = <<WARNING;
is_deeply() takes two or three args, you gave %d.
This usually means you passed an array or hash instead
of a reference to it
WARNING
chop $msg; # clip off newline so carp() will put in line/file
_carp sprintf $msg, scalar @_;
return $tb->ok(0);
}
my($got, $expected, $name) = @_;
$tb->_unoverload_str(\$expected, \$got);
my $ok;
if( !ref $got and !ref $expected ) { # neither is a reference
$ok = $tb->is_eq($got, $expected, $name);
}
elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
$ok = $tb->ok(0, $name);
$tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
}
else { # both references
local @Data_Stack = ();
if( _deep_check($got, $expected) ) {
$ok = $tb->ok(1, $name);
}
else {
$ok = $tb->ok(0, $name);
$tb->diag(_format_stack(@Data_Stack));
}
}
return $ok;
}
sub _format_stack {
my(@Stack) = @_;
my $var = '$FOO';
my $did_arrow = 0;
foreach my $entry (@Stack) {
my $type = $entry->{type} || '';
my $idx = $entry->{'idx'};
if( $type eq 'HASH' ) {
$var .= "->" unless $did_arrow++;
$var .= "{$idx}";
}
elsif( $type eq 'ARRAY' ) {
$var .= "->" unless $did_arrow++;
$var .= "[$idx]";
}
elsif( $type eq 'REF' ) {
$var = "\${$var}";
}
}
my @vals = @{$Stack[-1]{vals}}[0,1];
my @vars = ();
($vars[0] = $var) =~ s/\$FOO/ \$got/;
($vars[1] = $var) =~ s/\$FOO/\$expected/;
my $out = "Structures begin differing at:\n";
foreach my $idx (0..$#vals) {
my $val = $vals[$idx];
$vals[$idx] = !defined $val ? 'undef' :
_dne($val) ? "Does not exist" :
ref $val ? "$val" :
"'$val'";
}
$out .= "$vars[0] = $vals[0]\n";
$out .= "$vars[1] = $vals[1]\n";
$out =~ s/^/ /msg;
return $out;
}
sub _type {
my $thing = shift;
return '' if !ref $thing;
for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
return $type if UNIVERSAL::isa($thing, $type);
}
return '';
}
#line 925
sub diag {
my $tb = Test::More->builder;
$tb->diag(@_);
}
#line 994
#'#
sub skip {
my($why, $how_many) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
if( defined $how_many and $how_many =~ /\D/ ) {
_carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
$how_many = 1;
}
for( 1..$how_many ) {
$tb->skip($why);
}
local $^W = 0;
last SKIP;
}
#line 1081
sub todo_skip {
my($why, $how_many) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1..$how_many ) {
$tb->todo_skip($why);
}
local $^W = 0;
last TODO;
}
#line 1134
sub BAIL_OUT {
my $reason = shift;
my $tb = Test::More->builder;
$tb->BAIL_OUT($reason);
}
#line 1173
#'#
sub eq_array {
local @Data_Stack;
_deep_check(@_);
}
sub _eq_array {
my($a1, $a2) = @_;
if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
warn "eq_array passed a non-array ref";
return 0;
}
return 1 if $a1 eq $a2;
my $ok = 1;
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
for (0..$max) {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
$ok = _deep_check($e1,$e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}
sub _deep_check {
my($e1, $e2) = @_;
my $tb = Test::More->builder;
my $ok = 0;
# Effectively turn %Refs_Seen into a stack. This avoids picking up
# the same referenced used twice (such as [\$a, \$a]) to be considered
# circular.
local %Refs_Seen = %Refs_Seen;
{
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
$tb->_unoverload_str(\$e1, \$e2);
# Either they're both references or both not.
my $same_ref = !(!ref $e1 xor !ref $e2);
my $not_ref = (!ref $e1 and !ref $e2);
if( defined $e1 xor defined $e2 ) {
$ok = 0;
}
elsif ( _dne($e1) xor _dne($e2) ) {
$ok = 0;
}
elsif ( $same_ref and ($e1 eq $e2) ) {
$ok = 1;
}
elsif ( $not_ref ) {
push @Data_Stack, { type => '', vals => [$e1, $e2] };
$ok = 0;
}
else {
if( $Refs_Seen{$e1} ) {
return $Refs_Seen{$e1} eq $e2;
}
else {
$Refs_Seen{$e1} = "$e2";
}
my $type = _type($e1);
$type = 'DIFFERENT' unless _type($e2) eq $type;
if( $type eq 'DIFFERENT' ) {
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = 0;
}
elsif( $type eq 'ARRAY' ) {
$ok = _eq_array($e1, $e2);
}
elsif( $type eq 'HASH' ) {
$ok = _eq_hash($e1, $e2);
}
elsif( $type eq 'REF' ) {
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
elsif( $type eq 'SCALAR' ) {
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
elsif( $type ) {
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
$ok = 0;
}
else {
_whoa(1, "No type in _deep_check");
}
}
}
return $ok;
}
sub _whoa {
my($check, $desc) = @_;
if( $check ) {
die <<WHOA;
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
#line 1304
sub eq_hash {
local @Data_Stack;
return _deep_check(@_);
}
sub _eq_hash {
my($a1, $a2) = @_;
if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
warn "eq_hash passed a non-hash ref";
return 0;
}
return 1 if $a1 eq $a2;
my $ok = 1;
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
foreach my $k (keys %$bigger) {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
$ok = _deep_check($e1, $e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}
#line 1361
sub eq_set {
my($a1, $a2) = @_;
return 0 unless @$a1 == @$a2;
# There's faster ways to do this, but this is easiest.
local $^W = 0;
# It really doesn't matter how we sort them, as long as both arrays are
# sorted with the same algorithm.
#
# Ensure that references are not accidentally treated the same as a
# string containing the reference.
#
# Have to inline the sort routine due to a threading/sort bug.
# See [rt.cpan.org 6782]
#
# I don't know how references would be sorted so we just don't sort
# them. This means eq_set doesn't really work with refs.
return eq_array(
[grep(ref, @$a1), sort( grep(!ref, @$a1) )],
[grep(ref, @$a2), sort( grep(!ref, @$a2) )],
);
}
#line 1551
1;
inc/Test/Number/Delta.pm view on Meta::CPAN
#line 1
package Test::Number::Delta;
use strict;
#use warnings; bah -- not supported before 5.006
use vars qw ($VERSION @EXPORT @ISA);
$VERSION = "1.03";
# Required modules
use Carp;
use Test::Builder;
use Exporter;
@ISA = qw( Exporter );
@EXPORT = qw( delta_not_ok delta_ok delta_within delta_not_within );
#line 116
my $Test = Test::Builder->new;
my $Epsilon = 1e-6;
my $Relative = undef;
sub import {
my $self = shift;
my $pack = caller;
my $found = grep /within|relative/, @_;
croak "Can't specify more than one of 'within' or 'relative'"
if $found > 1;
if ($found) {
my ($param,$value) = splice @_, 0, 2;
croak "'$param' parameter must be non-zero"
if $value == 0;
if ($param eq 'within') {
$Epsilon = abs($value);
}
elsif ($param eq 'relative') {
$Relative = abs($value);
}
else {
croak "Test::Number::Delta parameters must come first";
}
}
$Test->exported_to($pack);
$Test->plan(@_);
$self->export_to_level(1, $self, $_) for @EXPORT;
}
#--------------------------------------------------------------------------#
# _check -- recursive function to perform comparison
#--------------------------------------------------------------------------#
sub _check {
my ($p, $q, $epsilon, $name, @indices) = @_;
my ($ok, $diag) = ( 1, q{} ); # assume true
if ( ref $p eq 'ARRAY' || ref $q eq 'ARRAY' ) {
if ( @$p == @$q ) {
for my $i ( 0 .. $#{$p} ) {
my @new_indices;
($ok, $diag, @new_indices) = _check(
$p->[$i],
$q->[$i],
$epsilon,
$name,
scalar @indices ? @indices : (),
$i,
);
if ( not $ok ) {
@indices = @new_indices;
last;
}
}
}
else {
$ok = 0;
$diag = "Got an array of length " . scalar(@$p) .
", but expected an array of length " . scalar(@$q);
}
}
else {
$ok = abs($p - $q) < $epsilon;
if ( ! $ok ) {
my ($ep, $dp) = _ep_dp( $epsilon );
$diag = sprintf("%.${dp}f and %.${dp}f are not equal" .
" to within %.${ep}f", $p, $q, $epsilon
);
}
}
return ( $ok, $diag, scalar(@indices) ? @indices : () );
}
sub _ep_dp {
my $epsilon = shift;
my ($exp) = sprintf("%e",$epsilon) =~ m/e(.+)/;
my $ep = $exp < 0 ? -$exp : 1;
my $dp = $ep + 1;
return ($ep, $dp);
}
#line 200
#--------------------------------------------------------------------------#
# delta_within()
#--------------------------------------------------------------------------#
#line 237
sub delta_within($$$;$) {
my ($p, $q, $epsilon, $name) = @_;
croak "Value of epsilon to delta_within must be non-zero"
if $epsilon == 0;
$epsilon = abs($epsilon);
my ($ok, $diag, @indices) = _check( $p, $q, $epsilon, $name );
if ( @indices ) {
$diag = "At [" . join( "][", @indices ) . "]: $diag";
}
return $Test->ok($ok,$name) || $Test->diag( $diag );
}
#--------------------------------------------------------------------------#
# delta_ok()
#--------------------------------------------------------------------------#
#line 264
sub delta_ok($$;$) {
my ($p, $q, $name) = @_;
{
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $e = $Relative
? $Relative * (abs($p) > abs($q) ? abs($p) : abs($q))
: $Epsilon;
delta_within( $p, $q, $e, $name );
}
}
#--------------------------------------------------------------------------#
# delta_not_ok()
#--------------------------------------------------------------------------#
#line 292
sub delta_not_within($$$;$) {
my ($p, $q, $epsilon, $name) = @_;
croak "Value of epsilon to delta_not_within must be non-zero"
if $epsilon == 0;
$epsilon = abs($epsilon);
my ($ok, undef, @indices) = _check( $p, $q, $epsilon, $name );
$ok = !$ok;
my ($ep, $dp) = _ep_dp( $epsilon );
my $diag = sprintf("Arguments are equal to within %.${ep}f", $epsilon);
return $Test->ok($ok,$name) || $Test->diag( $diag );
}
#line 315
sub delta_not_ok($$;$) {
my ($p, $q, $name) = @_;
{
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $e = $Relative
? $Relative * (abs($p) > abs($q) ? abs($p) : abs($q))
: $Epsilon;
delta_not_within( $p, $q, $e, $name );
}
}
1; #this line is important and will help the module return a true value
__END__
#line 387
lib/AI/MaxEntropy.pm view on Meta::CPAN
use strict;
use warnings;
package AI::MaxEntropy;
use Algorithm::LBFGS;
use AI::MaxEntropy::Model;
use XSLoader;
our $VERSION = '0.20';
XSLoader::load('AI::MaxEntropy', $VERSION);
sub new {
my $class = shift;
my $self = {
smoother => {},
algorithm => {},
@_,
samples => [],
x_bucket => {},
y_bucket => {},
x_list => [],
y_list => [],
x_num => 0,
y_num => 0,
f_num => 0,
af_num => 0,
f_freq => [],
f_map => [],
last_cut => -1,
_c => {}
};
return bless $self, $class;
}
sub see {
my ($self, $x, $y, $w) = @_;
$w = 1 if not defined($w);
my ($x1, $y1) = ([], undef);
# preprocess if $x is hashref
$x = [
map {
my $attr = $_;
ref($x->{$attr}) eq 'ARRAY' ?
map { "$attr:$_" } @{$x->{$attr}} : "$_:$x->{$_}"
} keys %$x
] if ref($x) eq 'HASH';
# update af_num
$self->{af_num} = scalar(@$x) if $self->{af_num} == 0;
$self->{af_num} = -1 if $self->{af_num} != scalar(@$x);
# convert y from string to ID
my $y_id = $self->{y_bucket}->{$y};
# new y
if (!defined($y_id)) {
# update y_list, y_num, y_bucket, f_freq
push @{$self->{y_list}}, $y;
$self->{y_num} = scalar(@{$self->{y_list}});
$y_id = $self->{y_num} - 1;
$self->{y_bucket}->{$y} = $y_id;
push @{$self->{f_freq}}, [map { 0 } (1 .. $self->{x_num})];
# save ID
$y1 = $y_id;
}
# old y
else { $y1 = $y_id }
# convert x from strings to IDs
for (@$x) {
my $x_id = $self->{x_bucket}->{$_};
# new x
if (!defined($x_id)) {
# update x_list, x_num, x_bucket, f_freq
push @{$self->{x_list}}, $_;
$self->{x_num} = scalar(@{$self->{x_list}});
$x_id = $self->{x_num} - 1;
$self->{x_bucket}->{$_} = $x_id;
push @{$self->{f_freq}->[$_]}, 0 for (0 .. $self->{y_num} - 1);
# save ID
push @$x1, $x_id;
}
# old x
else { push @$x1, $x_id }
# update f_freq
$self->{f_freq}->[$y_id]->[$x_id] += $w;
}
# add the sample
push @{$self->{samples}}, [$x1, $y1, $w];
$self->{last_cut} = -1;
}
sub cut {
my ($self, $t) = @_;
$self->{f_num} = 0;
for my $y (0 .. $self->{y_num} - 1) {
for my $x (0 .. $self->{x_num} - 1) {
if ($self->{f_freq}->[$y]->[$x] >= $t) {
$self->{f_map}->[$y]->[$x] = $self->{f_num};
$self->{f_num}++;
}
else { $self->{f_map}->[$y]->[$x] = -1 }
}
}
$self->{last_cut} = $t;
}
sub forget_all {
my $self = shift;
$self->{samples} = [];
$self->{x_bucket} = {};
$self->{y_bucket} = {};
$self->{x_num} = 0;
$self->{y_num} = 0;
$self->{f_num} = 0;
$self->{x_list} = [];
$self->{y_list} = [];
$self->{af_num} = 0;
$self->{f_freq} = [];
$self->{f_map} = [];
$self->{last_cut} = -1;
$self->{_c} = {};
}
sub _cache {
my $self = shift;
$self->_cache_samples;
$self->_cache_f_map;
}
sub _free_cache {
my $self = shift;
$self->_free_cache_samples;
$self->_free_cache_f_map;
}
sub learn {
my $self = shift;
# cut 0 for default
$self->cut(0) if $self->{last_cut} == -1;
# initialize
$self->{lambda} = [map { 0 } (1 .. $self->{f_num})];
$self->_cache;
# optimize
my $type = $self->{algorithm}->{type} || 'lbfgs';
if ($type eq 'lbfgs') {
my $o = Algorithm::LBFGS->new(%{$self->{algorithm}});
$o->fmin(\&_neg_log_likelihood, $self->{lambda},
$self->{algorithm}->{progress_cb}, $self);
}
elsif ($type eq 'gis') {
die 'GIS is not applicable'
if $self->{af_num} == -1 or $self->{last_cut} != 0;
my $progress_cb = $self->{algorithm}->{progress_cb};
$progress_cb = sub {
print "$_[0]: |lambda| = $_[3], |d_lambda| = $_[4]\n"; 0;
} if defined($progress_cb) and $progress_cb eq 'verbose';
my $epsilon = $self->{algorithm}->{epsilon} || 1e-3;
$self->{lambda} = $self->_apply_gis($progress_cb, $epsilon);
}
else { die "$type is not a valid algorithm type" }
# finish
$self->_free_cache;
return $self->_create_model;
}
sub _create_model {
my $self = shift;
my $model = AI::MaxEntropy::Model->new;
$model->{$_} = ref($self->{$_}) eq 'ARRAY' ? [@{$self->{$_}}] :
ref($self->{$_}) eq 'HASH' ? {%{$self->{$_}}} :
$self->{$_}
for qw/x_list y_list lambda x_num y_num f_num x_bucket y_bucket/;
$model->{f_map}->[$_] = [@{$self->{f_map}->[$_]}]
for (0 .. $self->{y_num} - 1);
return $model;
}
1;
__END__
=head1 NAME
AI::MaxEntropy - Perl extension for learning Maximum Entropy Models
=head1 SYNOPSIS
use AI::MaxEntropy;
# create a maximum entropy learner
my $me = AI::MaxEntropy->new;
# the learner see 2 red round smooth apples
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
# the learner see 3 yellow long smooth bananas
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
# and more
# samples needn't have the same numbers of active features
$me->see(['rough', 'big'] => 'pomelo');
# the order of active features is not concerned, too
$me->see(['big', 'rough'] => 'pomelo');
# ...
# and, let it learn
my $model = $me->learn;
# then, we can make predictions on unseen data
# ask what a red thing is most likely to be
print $model->predict(['red'])."\n";
# the answer is apple, because all red things the learner have ever seen
# are apples
# ask what a smooth thing is most likely to be
print $model->predict(['smooth'])."\n";
# the answer is banana, because the learner have seen more smooth bananas
# (weighted 3) than smooth apples (weighted 2)
# ask what a red, long thing is most likely to be
print $model->predict(['red', 'long'])."\n";
# the answer is banana, because the learner have seen more long bananas
# (weighted 3) than red apples (weighted 2)
# print out scores of all possible answers to the feature round and red
for ($model->all_labels) {
my $s = $model->score(['round', 'red'] => $_);
print "$_: $s\n";
}
# save the model
$model->save('model_file');
# load the model
$model->load('model_file');
=head1 CONCEPTS
=head2 What is a Maximum Entropy model?
Maximum Entropy (ME) model is a popular approach for machine learning.
From a user's view, it just behaves like a classifier which classify things
according to the previously learnt things.
Theorically, a ME learner try to recover the real probability distribution
of the data based on limited number of observations, by applying the
principle of maximum entropy.
You can find some good tutorials on Maximum Entropy model here:
L<http://homepages.inf.ed.ac.uk/s0450736/maxent.html>
=head2 Features
Generally, a feature is a binary function answers a yes-no question on a
specified piece of data.
For examples,
"Is it a red apple?"
"Is it a yellow banana?"
If the answer is yes,
we say this feature is active on that piece of data.
In practise, a feature is usually represented as
a tuple C<E<lt>x, yE<gt>>. For examples, the above two features can be
represented as
<red, apple>
<yellow, banana>
=head2 Samples
A sample is a set of active features, all of which share a common C<y>.
This common C<y> is sometimes called label or tag.
For example, we have a big round red apple, the correpsonding sample is
{<big, apple>, <round, apple>, <red, apple>}
In this module, a samples is denoted in Perl code as
$xs => $y => $w
C<$xs> is an array ref holding all C<x>,
C<$y> is a scalar holding the label
and C<$w> is the weight of the sample, which tells how many times the
sample occurs.
Therefore, the above sample can be denoted as
['big', 'round', 'red'] => 'apple' => 1.0
The weight C<$w> can be ommited when it equals to 1.0,
so the above denotation can be shorten to
['big', 'round', 'red'] => 'apple'
=head2 Models
With a set of samples, a model can be learnt for future predictions.
The model (the lambda vector essentailly) is a knowledge representation
of the samples that it have seen before.
By applying the model, we can calculate the probability of each possible
label for a certain sample. And choose the most possible one
according to these probabilities.
=head1 FUNCTIONS
NOTE: This is still an alpha version, the APIs may be changed
in future versions.
=head2 new
Create a Maximum Entropy learner. Optionally, initial values of properties
can be specified.
my $me1 = AI::MaxEntropy->new;
my $me2 = AI::MaxEntropy->new(
algorithm => { epsilon => 1e-6 });
my $me3 = AI::MaxEntropy->new(
algorithm => { m => 7, epsilon => 1e-4 },
smoother => { type => 'gaussian', sigma => 0.8 }
);
=head2 see
Let the Maximum Entropy learner see a sample.
my $me = AI::MaxEntropy->new;
# see a sample with default weight 1.0
$me->see(['red', 'round'] => 'apple');
# see a sample with specified weight 0.5
$me->see(['yellow', 'long'] => 'banana' => 0.5);
The sample can be also represented in the attribute-value form, which like
$me->see({color => 'yellow', shape => 'long'} => 'banana');
$me->see({color => ['red', 'green'], shape => 'round'} => 'apple');
Actually, the two samples above are converted internally to,
$me->see(['color:yellow', 'shape:long'] => 'banana');
$me->see(['color:red', 'color:green', 'shape:round'] => 'apple');
=head2 forget_all
Forget all samples the learner have seen previously.
=head2 cut
Cut the features that occur less than the specified number.
For example,
...
$me->cut(1)
will cut all features that occur less than one time.
=head2 learn
Learn a model from all the samples that the learner have seen so far,
returns an L<AI::MaxEntropy::Model> object, which can be used to make
prediction on unlabeled samples.
...
my $model = $me->learn;
print $model->predict(['x1', 'x2', ...]);
=head1 PROPERTIES
=head2 algorithm
This property enables client program to choose different algorithms for
learning the ME model and set their parameters.
There are mainly 3 algorithm for learning ME models, they are GIS, IIS and
L-BFGS. This module implements 2 of them, namely, L-BFGS and GIS.
L-BFGS provides full functionality, while GIS runs faster, but only
applicable on limited scenarios.
To use GIS, the following conditions must be satisified:
1. All samples have same number of active features
2. No feature has been cut
3. No smoother is used (in fact, the property L</smoother> is simplly
ignored when the type of algorithm equal to 'gis').
This property C<algorithm> is supposed to be a hash ref, like
{
type => ...,
progress_cb => ...,
param_1 => ...,
param_2 => ...,
...,
param_n => ...
}
=head3 type
The entry C<type =E<gt> ...> specifies which algorithm is used for the
optimization. Valid values include:
'lbfgs' Limited-memory Broyden-Fletcher-Goldfarb-Shanno (L-BFGS)
'gis' General Iterative Scaling (GIS)
If ommited, C<'lbfgs'> is used by default.
=head3 progress_cb
The entry C<progress_cb =E<gt> ...> specifies the progress callback
subroutine which is used to trace the process of the algorithm.
The specified callback routine will be called at each iteration of the
algorithm.
For L-BFGS, C<progress_cb> will be directly passed to
L<Algorithm::LBFGS/fmin>. C<f(x)> is the negative log-likelihood of current
lambda vector.
For GIS, the C<progress_cb> is supposed to have a prototype like
progress_cb(i, lambda, d_lambda, lambda_norm, d_lambda_norm)
C<i> is the number of the iterations, C<lambda> is an array ref containing
the current lambda vector, C<d_lambda> is an array ref containing the
delta of the lambda vector in current iteration, C<lambda_norm> and
C<d_lambda_norm> are Euclid norms of C<lambda> and C<d_lambda> respectively.
For both L-BFGS and GIS, the client program can also pass a string
C<'verbose'> to C<progress_cb> to use a default progress callback
which simply print out the progress on the screen.
C<progress_cb> can also be omitted if the client program
do not want to trace the progress.
=head3 parameters
The rest entries are parameters for the specified algorithm.
Each parameter will be assigned with its default value when it is not
given explicitly.
For L-BFGS, the parameters will be directly passed to
L<Algorithm::LBFGS> object, please refer to L<Algorithm::LBFGS/Parameters>
for details.
For GIS, there is only one parameter C<epsilon>, which controls the
precision of the algorithm (similar to the C<epsilon> in
L<Algorithm::LBFGS>). Generally speaking, a smaller C<epsilon> produces
a more precise result. The default value of C<epsilon> is 1e-3.
=head2 smoother
The smoother is a solution to the over-fitting problem.
This property chooses which type of smoother the client program want to
apply and sets the smoothing parameters.
Only one smoother have been implemented in this version of the module,
the Gaussian smoother.
One can apply the Gaussian smoother as following,
my $me = AI::MaxEntropy->new(
smoother => { type => 'gaussian', sigma => 0.6 }
);
The parameter C<sigma> indicates the strength of smoothing.
Usually, sigma is a positive number no greater than 1.0.
The strength of smoothing grows as sigma getting close to 0.
=head1 SEE ALSO
L<AI::MaxEntropy::Model>, L<AI::MaxEntropy::Util>
L<Algorithm::LBFGS>
L<Statistics::MaxEntropy>, L<Algorithm::CRF>, L<Algorithm::SVM>,
L<AI::DecisionTree>
=head1 AUTHOR
Laye Suen, E<lt>laye@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
=head1 REFERENCE
=over
=item
A. L. Berge, V. J. Della Pietra, S. A. Della Pietra.
A Maximum Entropy Approach to Natural Language Processing,
Computational Linguistics, 1996.
=item
S. F. Chen, R. Rosenfeld.
A Gaussian Prior for Smoothing Maximum Entropy Models,
February 1999 CMU-CS-99-108.
=back
lib/AI/MaxEntropy/Model.pm view on Meta::CPAN
use strict;
use warnings;
package AI::MaxEntropy::Model;
use YAML::Syck;
our $VERSION = '0.20';
sub new {
my ($class, $model) = @_;
my $self = bless {}, $class;
$self->load($model) if defined($model);
return $self;
}
sub load {
my ($self, $file) = @_;
my $model = LoadFile($file);
($self->{x_list}, $self->{y_list}, $self->{f_map}, $self->{lambda})
= @$model;
$self->{x_num} = scalar(@{$self->{x_list}});
$self->{y_num} = scalar(@{$self->{y_list}});
$self->{f_num} = scalar(@{$self->{lambda}});
$self->{x_bucket}->{$self->{x_list}->[$_]} = $_
for (0 .. $self->{x_num} - 1);
$self->{y_bucket}->{$self->{y_list}->[$_]} = $_
for (0 .. $self->{y_num} - 1);
}
sub save {
my ($self, $file) = @_;
my $data = [
$self->{x_list},
$self->{y_list},
$self->{f_map},
$self->{lambda}
];
DumpFile($file, $data);
}
sub all_x { @{$_[0]->{x_list}} }
sub all_labels { @{$_[0]->{y_list}} }
sub score {
my $self = shift;
my ($x, $y) = @_;
# preprocess if $x is hashref
$x = [
map {
my $attr = $_;
ref($x->{$attr}) eq 'ARRAY' ?
map { "$attr:$_" } @{$x->{$attr}} : "$_:$x->{$_}"
} keys %$x
] if ref($x) eq 'HASH';
# calculate score
my @x1 = map { $self->{x_bucket}->{$_} } @$x;
my $lambda_f = 0;
if (defined(my $y1 = $self->{y_bucket}->{$y})) {
for my $x1 (@x1) {
if (defined($x1)) {
my $lambda_i = $self->{f_map}->[$y1]->[$x1];
$lambda_f += $self->{lambda}->[$lambda_i]
if $lambda_i != -1;
}
}
}
return $lambda_f;
}
sub predict {
my $self = shift;
my $x = shift;
my @score = map { $self->score($x => $_) } @{$self->{y_list}};
my ($max_score, $max_y) = (undef, undef);
for my $y (0 .. $self->{y_num} - 1) {
($max_score, $max_y) = ($score[$y], $y) if not defined($max_y);
($max_score, $max_y) = ($score[$y], $y) if $score[$y] > $max_score;
}
return $self->{y_list}->[$max_y];
}
1;
__END__
=head1 NAME
AI::MaxEntropy::Model - Perl extension for using Maximum Entropy Models
=head1 SYNOPSIS
use AI::MaxEntropy::Model;
# learn a model by AI::MaxEntropy
require AI::MaxEntropy;
my $me = AI::MaxEntropy->new;
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
$me->see(['round', 'rough'] => 'orange' => 2);
my $model = $me->learn;
# make prediction on unseen data
# ask what a red round thing is most likely to be
my $y = $model->predict(['round', 'red']);
# the answer apple is expected
# print out scores of all possible labels
for ($model->all_labels) {
my $s = $model->score(['round', 'red'] => $_);
print "$_: $s\n";
}
# save the model to file
$model->save('model_file');
# load the model from file
$model->load('model_file');
=head1 DESCRIPTION
This module manipulates models learnt by L<AI::MaxEntropy>. For details
about Maximum Entropy learner, please refer to L<AI::MaxEntropy>.
=head1 FUNCTIONS
=head2 new
Create a new model object from a model file.
my $model = AI::MaxEntropy::Model->new('model_file');
=head2 predict
Get the most possible label for a unlabeled sample
...
$y = $model->predict(['round', 'red']);
=head2 score
Get scores for every possible label for a unlabeled sample
...
$s = $model->score(['round', 'red'] => 'apple');
=head2 save
Dumps the model to a file.
...
$model->save('model_file');
=head2 load
Loads the model from a file.
...
$model->load('model_file');
=head2 all_x
Returns a list of all x.
=head2 all_labels
Returns a list of all y (labels).
=head1 SEE ALSO
L<AI::MaxEntropy>
=head1 AUTHOR
Laye Suen, E<lt>laye@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
=head1 REFERENCE
=over
=item
A. L. Berge, V. J. Della Pietra, S. A. Della Pietra.
A Maximum Entropy Approach to Natural Language Processing,
Computational Linguistics, 1996.
=item
S. F. Chen, R. Rosenfeld.
A Gaussian Prior for Smoothing Maximum Entropy Models,
February 1999 CMU-CS-99-108.
=back
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
use strict;
use warnings;
package AI::MaxEntropy::Util;
use Exporter;
our $VERSION = '0.20';
our @ISA = qw/Exporter/;
our @EXPORT_OK =
qw/traverse_partially map_partially train_and_test precision recall/;
our %EXPORT_TAGS =
(all => [@EXPORT_OK]);
sub traverse_partially(&$$;$) {
my ($code, $samples, $pattern, $t) = @_;
$t ||= 'x';
my ($p, $n) = (length($pattern), scalar(@$samples));
for my $i (grep { substr($pattern, $_, 1) eq $t } (0 .. $p - 1)) {
for (int($n * $i / $p) .. int($n * ($i + 1) / $p) - 1) {
$_ = $samples->[$_];
$code->();
}
}
}
sub map_partially(&$$;$) {
my ($code, $samples, $pattern, $t) = @_;
my @r;
traverse_partially { push @r, $code->($_) } $samples, $pattern, $t;
return \@r;
}
sub train_and_test {
my ($me, $samples, $pattern) = @_;
traverse_partially { $me->see(@$_) } $samples, $pattern, 'x';
my $m = $me->learn;
my $r = map_partially { [$_ => $m->predict($_->[0])] }
$samples, $pattern, 'o';
return ($r, $m);
}
sub precision {
my $r = shift;
my ($c, $n) = (0, 0);
for (@$r) {
my $w = defined($_->[0]->[2]) ? $_->[0]->[2] : 1;
$n += $w;
$c += $w if $_->[0]->[1] eq $_->[1];
}
return $c / $n;
}
sub recall {
my $r = shift;
my $label = shift;
my ($c, $n) = (0, 0);
for (@$r) {
if ($_->[0]->[1] eq $label) {
my $w = defined($_->[0]->[2]) ? $_->[0]->[2] : 1;
$n += $w;
$c += $w if $_->[1] eq $label;
}
}
return $c / $n;
}
1;
__END__
=head1 NAME
AI::MaxEntropy::Util - Utilities for doing experiments with ME learners
=head1 SYNOPSIS
use AI::MaxEntropy;
use AI::MaxEntropy::Util qw/:all/;
my $me = AI::MaxEntropy->new;
my $samples = [
[['a', 'b', 'c'] => 'x'],
[['e', 'f'] => 'y' => 1.5],
...
];
my ($result, $model) = train_and_test($me, $samples, 'xxxo');
print precision($result)."\n";
print recall($result, 'x')."\n";
=head1 DESCRIPTION
This module makes doing experiments with Maximum Entropy learner easier.
Generally, an experiment involves a training set and a testing set
(sometimes also a parameter adjusting set). The learner is trained with
samples in the training set and tested with samples in the testing set.
Usually, 2 measures of performance are concerned.
One is precision, indicating the percentage of samples which are correctly
predicted in the testing set. The other one is recall, indicating the
precision of samples with a certain label.
=head1 FUNCTIONS
=head2 train_and_test
This function automated the process of training and testing.
my $me = AI::MaxEntropy->new;
my $sample = [
[ ['a', 'b'] => 'x' => 1.5 ],
...
];
my ($result, $model) = train_and_test($me, $sample, 'xxxo');
First, the whole samples set will be divided into a training set and a
testing set according to the specified pattern. A pattern is a string,
in which each character stands for a part of the samples set.
If the character is C<'x'>, the corresponding part is used for training.
If the character is C<'o'>, the corresponding part is used for testing.
Otherwise, the corresponding part is simply ignored.
For example, the pattern 'xxxo' means the first three forth of the samples
set are used for training while the last one forth is used for testing.
The function returns two values. The first one is an array ref describe
the result of testing, in which each element follows a structure like
C<[sample =E<gt> result]>. The second one is the model learnt from the
training set, which is an L<AI::MaxEntropy::Model> object.
=head2 traverse_partially
This function is the core implementation of L</train_and_test>. It traverse
through some of the elements in an array according to a pattern,
and does some specified actions with each of these elements.
my $arr = [1, 2, 3, 4, 5];
# print out the first two firth of the array
traverse_partially { print } $arr, 'xx---';
# do the same thing, using custom significant character 'o'
traverse_partially { print } $arr, 'oo---' => 'o';
my $samples = [
[['a', 'b'] => 'x'],
[['c', 'd'] => 'y' => 1.5],
...
];
my $me = AI::MaxEntropy->new;
# see the first one third and the last one third samples
traverse_partially { $me->see(@$_) } $samples, 'x-x';
=head2 map_partially
This function is similar to L</traverse_partially>. However, it returns an
array ref in which all elements in the original array is mapped according
to the code snippet's return value.
my $arr = [1, 2, 3, 4, 5];
# increase the last one third of the elements by 1
$arr = map_partially { $_ + 1 } $arr, '--x';
=head2 precision
Calculates the precision based on the result returned by
L</train_and_test>.
...
my ($result, $model) = train_and_test(...);
print precision($result)."\n";
Note that the weights of samples are taken into consideration.
=head2 recall
Calculates the recall of a certain label based on the result returned by
L</train_and_test>.
...
my ($result, $model) = train_and_test(...);
print recall($result, 'label')."\n";
Note that the weights of samples are taken into consideration.
=head1 SEE ALSO
L<AI::MaxEntropy>, L<AI::MaxEntropy::Model>
=head1 AUTHOR
Laye Suen, E<lt>laye@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
#if 0
<<'SKIP';
#endif
/*
----------------------------------------------------------------------
ppport.h -- Perl/Pollution/Portability Version 3.06_01
Automatically created by Devel::PPPort running under
perl 5.008008 on Tue Jan 8 15:31:18 2008.
Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
includes in parts/inc/ instead.
Use 'perldoc ppport.h' to view the documentation below.
----------------------------------------------------------------------
SKIP
=pod
=head1 NAME
ppport.h - Perl/Pollution/Portability version 3.06_01
=head1 SYNOPSIS
perl ppport.h [options] [source files]
Searches current directory for files if no [source files] are given
--help show short help
--patch=file write one patch file with changes
--copy=suffix write changed copies with suffix
--diff=program use diff program and options
--compat-version=version provide compatibility with Perl version
--cplusplus accept C++ comments
--quiet don't output anything except fatal errors
--nodiag don't show diagnostics
--nohints don't show hints
--nochanges don't suggest changes
--nofilter don't filter input files
--list-provided list provided API
--list-unsupported list unsupported API
--api-info=name show Perl API portability information
=head1 COMPATIBILITY
This version of F<ppport.h> is designed to support operation with Perl
installations back to 5.003, and has been tested up to 5.9.3.
=head1 OPTIONS
=head2 --help
Display a brief usage summary.
=head2 --patch=I<file>
If this option is given, a single patch file will be created if
any changes are suggested. This requires a working diff program
to be installed on your system.
=head2 --copy=I<suffix>
If this option is given, a copy of each file will be saved with
the given suffix that contains the suggested changes. This does
not require any external programs.
If neither C<--patch> or C<--copy> are given, the default is to
simply print the diffs for each file. This requires either
C<Text::Diff> or a C<diff> program to be installed.
=head2 --diff=I<program>
Manually set the diff program and options to use. The default
is to use C<Text::Diff>, when installed, and output unified
context diffs.
=head2 --compat-version=I<version>
Tell F<ppport.h> to check for compatibility with the given
Perl version. The default is to check for compatibility with Perl
version 5.003. You can use this option to reduce the output
of F<ppport.h> if you intend to be backward compatible only
up to a certain Perl version.
=head2 --cplusplus
Usually, F<ppport.h> will detect C++ style comments and
replace them with C style comments for portability reasons.
Using this option instructs F<ppport.h> to leave C++
comments untouched.
=head2 --quiet
Be quiet. Don't print anything except fatal errors.
=head2 --nodiag
Don't output any diagnostic messages. Only portability
alerts will be printed.
=head2 --nohints
Don't output any hints. Hints often contain useful portability
notes.
=head2 --nochanges
Don't suggest any changes. Only give diagnostic output and hints
unless these are also deactivated.
=head2 --nofilter
Don't filter the list of input files. By default, files not looking
like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
=head2 --list-provided
Lists the API elements for which compatibility is provided by
F<ppport.h>. Also lists if it must be explicitly requested,
if it has dependencies, and if there are hints for it.
=head2 --list-unsupported
Lists the API elements that are known not to be supported by
F<ppport.h> and below which version of Perl they probably
won't be available or work.
=head2 --api-info=I<name>
Show portability information for API elements matching I<name>.
If I<name> is surrounded by slashes, it is interpreted as a regular
expression.
=head1 DESCRIPTION
In order for a Perl extension (XS) module to be as portable as possible
across differing versions of Perl itself, certain steps need to be taken.
=over 4
=item *
Including this header is the first major one. This alone will give you
access to a large part of the Perl API that hasn't been available in
earlier Perl releases. Use
perl ppport.h --list-provided
to see which API elements are provided by ppport.h.
=item *
You should avoid using deprecated parts of the API. For example, using
global Perl variables without the C<PL_> prefix is deprecated. Also,
some API functions used to have a C<perl_> prefix. Using this form is
also deprecated. You can safely use the supported API, as F<ppport.h>
will provide wrappers for older Perl versions.
=item *
If you use one of a few functions that were not present in earlier
versions of Perl, and that can't be provided using a macro, you have
to explicitly request support for these functions by adding one or
more C<#define>s in your source code before the inclusion of F<ppport.h>.
These functions will be marked C<explicit> in the list shown by
C<--list-provided>.
Depending on whether you module has a single or multiple files that
use such functions, you want either C<static> or global variants.
For a C<static> function, use:
#define NEED_function
For a global function, use:
#define NEED_function_GLOBAL
Note that you mustn't have more than one global request for one
function in your project.
Function Static Request Global Request
-----------------------------------------------------------------------------------------
eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
grok_number() NEED_grok_number NEED_grok_number_GLOBAL
grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
To avoid namespace conflicts, you can change the namespace of the
explicitly exported functions using the C<DPPP_NAMESPACE> macro.
Just C<#define> the macro before including C<ppport.h>:
#define DPPP_NAMESPACE MyOwnNamespace_
#include "ppport.h"
The default namespace is C<DPPP_>.
=back
The good thing is that most of the above can be checked by running
F<ppport.h> on your source code. See the next section for
details.
=head1 EXAMPLES
To verify whether F<ppport.h> is needed for your module, whether you
should make any changes to your code, and whether any special defines
should be used, F<ppport.h> can be run as a Perl script to check your
source code. Simply say:
perl ppport.h
The result will usually be a list of patches suggesting changes
that should at least be acceptable, if not necessarily the most
efficient solution, or a fix for all possible problems.
If you know that your XS module uses features only available in
newer Perl releases, if you're aware that it uses C++ comments,
and if you want all suggestions as a single patch file, you could
use something like this:
perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
If you only want your code to be scanned without any suggestions
for changes, use:
perl ppport.h --nochanges
You can specify a different C<diff> program or options, using
the C<--diff> option:
perl ppport.h --diff='diff -C 10'
This would output context diffs with 10 lines of context.
To display portability information for the C<newSVpvn> function,
use:
perl ppport.h --api-info=newSVpvn
Since the argument to C<--api-info> can be a regular expression,
you can use
perl ppport.h --api-info=/_nomg$/
to display portability information for all C<_nomg> functions or
perl ppport.h --api-info=/./
to display information for all known API elements.
=head1 BUGS
If this version of F<ppport.h> is causing failure during
the compilation of this module, please check if newer versions
of either this module or C<Devel::PPPort> are available on CPAN
before sending a bug report.
If F<ppport.h> was generated using the latest version of
C<Devel::PPPort> and is causing failure of this module, please
file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
Please include the following information:
=over 4
=item 1.
The complete output from running "perl -V"
=item 2.
This file.
=item 3.
The name and version of the module you were trying to build.
=item 4.
A full log of the build that failed.
=item 5.
Any other information that you think could be relevant.
=back
For the latest version of this code, please get the C<Devel::PPPort>
module from CPAN.
=head1 COPYRIGHT
Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz.
Version 2.x, Copyright (C) 2001, Paul Marquess.
Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
See L<Devel::PPPort>.
=cut
use strict;
my %opt = (
quiet => 0,
diag => 1,
hints => 1,
changes => 1,
cplusplus => 0,
filter => 1,
);
my($ppport) = $0 =~ /([\w.]+)$/;
my $LF = '(?:\r\n|[\r\n])'; # line feed
my $HS = "[ \t]"; # horizontal whitespace
eval {
require Getopt::Long;
Getopt::Long::GetOptions(\%opt, qw(
help quiet diag! filter! hints! changes! cplusplus
patch=s copy=s diff=s compat-version=s
list-provided list-unsupported api-info=s
)) or usage();
};
if ($@ and grep /^-/, @ARGV) {
usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
die "Getopt::Long not found. Please don't use any options.\n";
}
usage() if $opt{help};
if (exists $opt{'compat-version'}) {
my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
if ($@) {
die "Invalid version number format: '$opt{'compat-version'}'\n";
}
die "Only Perl 5 is supported\n" if $r != 5;
die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
$opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
$opt{'compat-version'} = 5;
}
# Never use C comments in this file!!!!!
my $ccs = '/'.'*';
my $cce = '*'.'/';
my $rccs = quotemeta $ccs;
my $rcce = quotemeta $cce;
my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
? ( $1 => {
($2 ? ( base => $2 ) : ()),
($3 ? ( todo => $3 ) : ()),
(index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
(index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
(index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
} )
: die "invalid spec: $_" } qw(
AvFILLp|5.004050||p
AvFILL|||
CLASS|||n
CX_CURPAD_SAVE|||
CX_CURPAD_SV|||
CopFILEAV|5.006000||p
CopFILEGV_set|5.006000||p
CopFILEGV|5.006000||p
CopFILESV|5.006000||p
CopFILE_set|5.006000||p
CopFILE|5.006000||p
CopSTASHPV_set|5.006000||p
CopSTASHPV|5.006000||p
CopSTASH_eq|5.006000||p
CopSTASH_set|5.006000||p
CopSTASH|5.006000||p
CopyD|5.009002||p
Copy|||
CvPADLIST|||
CvSTASH|||
CvWEAKOUTSIDE|||
DEFSV|5.004050||p
END_EXTERN_C|5.005000||p
ENTER|||
ERRSV|5.004050||p
EXTEND|||
EXTERN_C|5.005000||p
FREETMPS|||
GIMME_V||5.004000|n
GIMME|||n
GROK_NUMERIC_RADIX|5.007002||p
G_ARRAY|||
G_DISCARD|||
G_EVAL|||
G_NOARGS|||
G_SCALAR|||
G_VOID||5.004000|
GetVars|||
GvSV|||
Gv_AMupdate|||
HEf_SVKEY||5.004000|
HeHASH||5.004000|
HeKEY||5.004000|
HeKLEN||5.004000|
HePV||5.004000|
HeSVKEY_force||5.004000|
HeSVKEY_set||5.004000|
HeSVKEY||5.004000|
HeVAL||5.004000|
HvNAME|||
INT2PTR|5.006000||p
IN_LOCALE_COMPILETIME|5.007002||p
IN_LOCALE_RUNTIME|5.007002||p
IN_LOCALE|5.007002||p
IN_PERL_COMPILETIME|5.008001||p
IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
IS_NUMBER_INFINITY|5.007002||p
IS_NUMBER_IN_UV|5.007002||p
IS_NUMBER_NAN|5.007003||p
IS_NUMBER_NEG|5.007002||p
IS_NUMBER_NOT_INT|5.007002||p
IVSIZE|5.006000||p
IVTYPE|5.006000||p
IVdf|5.006000||p
LEAVE|||
LVRET|||
MARK|||
MY_CXT_CLONE|5.009002||p
MY_CXT_INIT|5.007003||p
MY_CXT|5.007003||p
MoveD|5.009002||p
Move|||
NEWSV|||
NOOP|5.005000||p
NUM2PTR|5.006000||p
NVTYPE|5.006000||p
NVef|5.006001||p
NVff|5.006001||p
NVgf|5.006001||p
Newc|||
Newz|||
New|||
Nullav|||
Nullch|||
Nullcv|||
Nullhv|||
Nullsv|||
ORIGMARK|||
PAD_BASE_SV|||
PAD_CLONE_VARS|||
PAD_COMPNAME_FLAGS|||
PAD_COMPNAME_GEN_set|||
PAD_COMPNAME_GEN|||
PAD_COMPNAME_OURSTASH|||
PAD_COMPNAME_PV|||
PAD_COMPNAME_TYPE|||
PAD_RESTORE_LOCAL|||
PAD_SAVE_LOCAL|||
PAD_SAVE_SETNULLPAD|||
PAD_SETSV|||
PAD_SET_CUR_NOSAVE|||
PAD_SET_CUR|||
PAD_SVl|||
PAD_SV|||
PERL_BCDVERSION|5.009003||p
PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
PERL_INT_MAX|5.004000||p
PERL_INT_MIN|5.004000||p
PERL_LONG_MAX|5.004000||p
PERL_LONG_MIN|5.004000||p
PERL_MAGIC_arylen|5.007002||p
PERL_MAGIC_backref|5.007002||p
PERL_MAGIC_bm|5.007002||p
PERL_MAGIC_collxfrm|5.007002||p
PERL_MAGIC_dbfile|5.007002||p
PERL_MAGIC_dbline|5.007002||p
PERL_MAGIC_defelem|5.007002||p
PERL_MAGIC_envelem|5.007002||p
PERL_MAGIC_env|5.007002||p
PERL_MAGIC_ext|5.007002||p
PERL_MAGIC_fm|5.007002||p
PERL_MAGIC_glob|5.007002||p
PERL_MAGIC_isaelem|5.007002||p
PERL_MAGIC_isa|5.007002||p
PERL_MAGIC_mutex|5.007002||p
PERL_MAGIC_nkeys|5.007002||p
PERL_MAGIC_overload_elem|5.007002||p
PERL_MAGIC_overload_table|5.007002||p
PERL_MAGIC_overload|5.007002||p
PERL_MAGIC_pos|5.007002||p
PERL_MAGIC_qr|5.007002||p
PERL_MAGIC_regdata|5.007002||p
PERL_MAGIC_regdatum|5.007002||p
PERL_MAGIC_regex_global|5.007002||p
PERL_MAGIC_shared_scalar|5.007003||p
PERL_MAGIC_shared|5.007003||p
PERL_MAGIC_sigelem|5.007002||p
PERL_MAGIC_sig|5.007002||p
PERL_MAGIC_substr|5.007002||p
PERL_MAGIC_sv|5.007002||p
PERL_MAGIC_taint|5.007002||p
PERL_MAGIC_tiedelem|5.007002||p
PERL_MAGIC_tiedscalar|5.007002||p
PERL_MAGIC_tied|5.007002||p
PERL_MAGIC_utf8|5.008001||p
PERL_MAGIC_uvar_elem|5.007003||p
PERL_MAGIC_uvar|5.007002||p
PERL_MAGIC_vec|5.007002||p
PERL_MAGIC_vstring|5.008001||p
PERL_QUAD_MAX|5.004000||p
PERL_QUAD_MIN|5.004000||p
PERL_REVISION|5.006000||p
PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
PERL_SCAN_DISALLOW_PREFIX|5.007003||p
PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
PERL_SHORT_MAX|5.004000||p
PERL_SHORT_MIN|5.004000||p
PERL_SUBVERSION|5.006000||p
PERL_UCHAR_MAX|5.004000||p
PERL_UCHAR_MIN|5.004000||p
PERL_UINT_MAX|5.004000||p
PERL_UINT_MIN|5.004000||p
PERL_ULONG_MAX|5.004000||p
PERL_ULONG_MIN|5.004000||p
PERL_UNUSED_DECL|5.007002||p
PERL_UQUAD_MAX|5.004000||p
PERL_UQUAD_MIN|5.004000||p
PERL_USHORT_MAX|5.004000||p
PERL_USHORT_MIN|5.004000||p
PERL_VERSION|5.006000||p
PL_DBsingle|||pn
PL_DBsub|||pn
PL_DBtrace|||n
PL_Sv|5.005000||p
PL_compiling|5.004050||p
PL_copline|5.005000||p
PL_curcop|5.004050||p
PL_curstash|5.004050||p
PL_debstash|5.004050||p
PL_defgv|5.004050||p
PL_diehook|5.004050||p
PL_dirty|5.004050||p
PL_dowarn|||pn
PL_errgv|5.004050||p
PL_hexdigit|5.005000||p
PL_hints|5.005000||p
PL_last_in_gv|||n
PL_modglobal||5.005000|n
PL_na|5.004050||pn
PL_no_modify|5.006000||p
PL_ofs_sv|||n
PL_perl_destruct_level|5.004050||p
PL_perldb|5.004050||p
PL_ppaddr|5.006000||p
PL_rsfp_filters|5.004050||p
PL_rsfp|5.004050||p
PL_rs|||n
PL_stack_base|5.004050||p
PL_stack_sp|5.004050||p
PL_stdingv|5.004050||p
PL_sv_arenaroot|5.004050||p
PL_sv_no|5.004050||pn
PL_sv_undef|5.004050||pn
PL_sv_yes|5.004050||pn
PL_tainted|5.004050||p
PL_tainting|5.004050||p
POPi|||n
POPl|||n
POPn|||n
POPpbytex||5.007001|n
POPpx||5.005030|n
POPp|||n
POPs|||n
PTR2IV|5.006000||p
PTR2NV|5.006000||p
PTR2UV|5.006000||p
PTR2ul|5.007001||p
PTRV|5.006000||p
PUSHMARK|||
PUSHi|||
PUSHmortal|5.009002||p
PUSHn|||
PUSHp|||
PUSHs|||
PUSHu|5.004000||p
PUTBACK|||
PerlIO_clearerr||5.007003|
PerlIO_close||5.007003|
PerlIO_eof||5.007003|
PerlIO_error||5.007003|
PerlIO_fileno||5.007003|
PerlIO_fill||5.007003|
PerlIO_flush||5.007003|
PerlIO_get_base||5.007003|
PerlIO_get_bufsiz||5.007003|
PerlIO_get_cnt||5.007003|
PerlIO_get_ptr||5.007003|
PerlIO_read||5.007003|
PerlIO_seek||5.007003|
PerlIO_set_cnt||5.007003|
PerlIO_set_ptrcnt||5.007003|
PerlIO_setlinebuf||5.007003|
PerlIO_stderr||5.007003|
PerlIO_stdin||5.007003|
PerlIO_stdout||5.007003|
PerlIO_tell||5.007003|
PerlIO_unread||5.007003|
PerlIO_write||5.007003|
Poison|5.008000||p
RETVAL|||n
Renewc|||
Renew|||
SAVECLEARSV|||
SAVECOMPPAD|||
SAVEPADSV|||
SAVETMPS|||
SAVE_DEFSV|5.004050||p
SPAGAIN|||
SP|||
START_EXTERN_C|5.005000||p
START_MY_CXT|5.007003||p
STMT_END|||p
STMT_START|||p
ST|||
SVt_IV|||
SVt_NV|||
SVt_PVAV|||
SVt_PVCV|||
SVt_PVHV|||
SVt_PVMG|||
SVt_PV|||
Safefree|||
Slab_Alloc|||
Slab_Free|||
StructCopy|||
SvCUR_set|||
SvCUR|||
SvEND|||
SvGETMAGIC|5.004050||p
SvGROW|||
SvIOK_UV||5.006000|
SvIOK_notUV||5.006000|
SvIOK_off|||
SvIOK_only_UV||5.006000|
SvIOK_only|||
SvIOK_on|||
SvIOKp|||
SvIOK|||
SvIVX|||
SvIV_nomg|5.009001||p
SvIV_set|||
SvIVx|||
SvIV|||
SvIsCOW_shared_hash||5.008003|
SvIsCOW||5.008003|
SvLEN_set|||
SvLEN|||
SvLOCK||5.007003|
SvMAGIC_set||5.009003|
SvNIOK_off|||
SvNIOKp|||
SvNIOK|||
SvNOK_off|||
SvNOK_only|||
SvNOK_on|||
SvNOKp|||
SvNOK|||
SvNVX|||
SvNV_set|||
SvNVx|||
SvNV|||
SvOK|||
SvOOK|||
SvPOK_off|||
SvPOK_only_UTF8||5.006000|
SvPOK_only|||
SvPOK_on|||
SvPOKp|||
SvPOK|||
SvPVX|||
SvPV_force_nomg|5.007002||p
SvPV_force|||
SvPV_nolen|5.006000||p
SvPV_nomg|5.007002||p
SvPV_set|||
SvPVbyte_force||5.009002|
SvPVbyte_nolen||5.006000|
SvPVbytex_force||5.006000|
SvPVbytex||5.006000|
SvPVbyte|5.006000||p
SvPVutf8_force||5.006000|
SvPVutf8_nolen||5.006000|
SvPVutf8x_force||5.006000|
SvPVutf8x||5.006000|
SvPVutf8||5.006000|
SvPVx|||
SvPV|||
SvREFCNT_dec|||
SvREFCNT_inc|||
SvREFCNT|||
SvROK_off|||
SvROK_on|||
SvROK|||
SvRV_set||5.009003|
SvRV|||
SvSETMAGIC|||
SvSHARE||5.007003|
SvSTASH_set||5.009003|
SvSTASH|||
SvSetMagicSV_nosteal||5.004000|
SvSetMagicSV||5.004000|
SvSetSV_nosteal||5.004000|
SvSetSV|||
SvTAINTED_off||5.004000|
SvTAINTED_on||5.004000|
SvTAINTED||5.004000|
SvTAINT|||
SvTRUE|||
SvTYPE|||
SvUNLOCK||5.007003|
SvUOK||5.007001|
SvUPGRADE|||
SvUTF8_off||5.006000|
SvUTF8_on||5.006000|
SvUTF8||5.006000|
SvUVXx|5.004000||p
SvUVX|5.004000||p
SvUV_nomg|5.009001||p
SvUV_set||5.009003|
SvUVx|5.004000||p
SvUV|5.004000||p
SvVOK||5.008001|
THIS|||n
UNDERBAR|5.009002||p
UVSIZE|5.006000||p
UVTYPE|5.006000||p
UVXf|5.007001||p
UVof|5.006000||p
UVuf|5.006000||p
UVxf|5.006000||p
XCPT_CATCH|5.009002||p
XCPT_RETHROW|5.009002||p
XCPT_TRY_END|5.009002||p
XCPT_TRY_START|5.009002||p
XPUSHi|||
XPUSHmortal|5.009002||p
XPUSHn|||
XPUSHp|||
XPUSHs|||
XPUSHu|5.004000||p
XSRETURN_EMPTY|||
XSRETURN_IV|||
XSRETURN_NO|||
XSRETURN_NV|||
XSRETURN_PV|||
XSRETURN_UNDEF|||
XSRETURN_UV|5.008001||p
XSRETURN_YES|||
XSRETURN|||
XST_mIV|||
XST_mNO|||
XST_mNV|||
XST_mPV|||
XST_mUNDEF|||
XST_mUV|5.008001||p
XST_mYES|||
XS_VERSION_BOOTCHECK|||
XS_VERSION|||
XS|||
ZeroD|5.009002||p
Zero|||
_aMY_CXT|5.007003||p
_pMY_CXT|5.007003||p
aMY_CXT_|5.007003||p
aMY_CXT|5.007003||p
aTHX_|5.006000||p
aTHX|5.006000||p
add_data|||
allocmy|||
amagic_call|||
any_dup|||
ao|||
append_elem|||
append_list|||
apply_attrs_my|||
apply_attrs_string||5.006001|
apply_attrs|||
apply|||
asIV|||
asUV|||
atfork_lock||5.007003|n
atfork_unlock||5.007003|n
av_arylen_p||5.009003|
av_clear|||
av_delete||5.006000|
av_exists||5.006000|
av_extend|||
av_fake|||
av_fetch|||
av_fill|||
av_len|||
av_make|||
av_pop|||
av_push|||
av_reify|||
av_shift|||
av_store|||
av_undef|||
av_unshift|||
ax|||n
bad_type|||
bind_match|||
block_end|||
block_gimme||5.004000|
block_start|||
boolSV|5.004000||p
boot_core_PerlIO|||
boot_core_UNIVERSAL|||
boot_core_xsutils|||
bytes_from_utf8||5.007001|
bytes_to_utf8||5.006001|
cache_re|||
call_argv|5.006000||p
call_atexit||5.006000|
call_body|||
call_list_body|||
call_list||5.004000|
call_method|5.006000||p
call_pv|5.006000||p
call_sv|5.006000||p
calloc||5.007002|n
cando|||
cast_i32||5.006000|
cast_iv||5.006000|
cast_ulong||5.006000|
cast_uv||5.006000|
check_uni|||
checkcomma|||
checkposixcc|||
ck_anoncode|||
ck_bitop|||
ck_concat|||
ck_defined|||
ck_delete|||
ck_die|||
ck_eof|||
ck_eval|||
ck_exec|||
ck_exists|||
ck_exit|||
ck_ftst|||
ck_fun|||
ck_glob|||
ck_grep|||
ck_index|||
ck_join|||
ck_lengthconst|||
ck_lfun|||
ck_listiob|||
ck_match|||
ck_method|||
ck_null|||
ck_open|||
ck_repeat|||
ck_require|||
ck_retarget|||
ck_return|||
ck_rfun|||
ck_rvconst|||
ck_sassign|||
ck_select|||
ck_shift|||
ck_sort|||
ck_spair|||
ck_split|||
ck_subr|||
ck_substr|||
ck_svconst|||
ck_trunc|||
ck_unpack|||
cl_and|||
cl_anything|||
cl_init_zero|||
cl_init|||
cl_is_anything|||
cl_or|||
closest_cop|||
convert|||
cop_free|||
cr_textfilter|||
croak_nocontext|||vn
croak|||v
csighandler||5.007001|n
custom_op_desc||5.007003|
custom_op_name||5.007003|
cv_ckproto|||
cv_clone|||
cv_const_sv||5.004000|
cv_dump|||
cv_undef|||
cx_dump||5.005000|
cx_dup|||
cxinc|||
dAXMARK||5.009003|
dAX|5.007002||p
dITEMS|5.007002||p
dMARK|||
dMY_CXT_SV|5.007003||p
dMY_CXT|5.007003||p
dNOOP|5.006000||p
dORIGMARK|||
dSP|||
dTHR|5.004050||p
dTHXa|5.006000||p
dTHXoa|5.006000||p
dTHX|5.006000||p
dUNDERBAR|5.009002||p
dXCPT|5.009002||p
dXSARGS|||
dXSI32|||
dXSTARG|5.006000||p
deb_curcv|||
deb_nocontext|||vn
deb_stack_all|||
deb_stack_n|||
debop||5.005000|
debprofdump||5.005000|
debprof|||
debstackptrs||5.007003|
debstack||5.007003|
deb||5.007003|v
del_he|||
del_sv|||
delimcpy||5.004000|
depcom|||
deprecate_old|||
deprecate|||
despatch_signals||5.007001|
die_nocontext|||vn
die_where|||
die|||v
dirp_dup|||
div128|||
djSP|||
do_aexec5|||
do_aexec|||
do_aspawn|||
do_binmode||5.004050|
do_chomp|||
do_chop|||
do_close|||
do_dump_pad|||
do_eof|||
do_exec3|||
do_execfree|||
do_exec|||
do_gv_dump||5.006000|
do_gvgv_dump||5.006000|
do_hv_dump||5.006000|
do_ipcctl|||
do_ipcget|||
do_join|||
do_kv|||
do_magic_dump||5.006000|
do_msgrcv|||
do_msgsnd|||
do_oddball|||
do_op_dump||5.006000|
do_open9||5.006000|
do_openn||5.007001|
do_open||5.004000|
do_pipe|||
do_pmop_dump||5.006000|
do_print|||
do_readline|||
do_seek|||
do_semop|||
do_shmio|||
do_spawn_nowait|||
do_spawn|||
do_sprintf|||
do_sv_dump||5.006000|
do_sysseek|||
do_tell|||
do_trans_complex_utf8|||
do_trans_complex|||
do_trans_count_utf8|||
do_trans_count|||
do_trans_simple_utf8|||
do_trans_simple|||
do_trans|||
do_vecget|||
do_vecset|||
do_vop|||
docatch_body|||
docatch|||
doeval|||
dofile|||
dofindlabel|||
doform|||
doing_taint||5.008001|n
dooneliner|||
doopen_pm|||
doparseform|||
dopoptoeval|||
dopoptolabel|||
dopoptoloop|||
dopoptosub_at|||
dopoptosub|||
dounwind|||
dowantarray|||
dump_all||5.006000|
dump_eval||5.006000|
dump_fds|||
dump_form||5.006000|
dump_indent||5.006000|v
dump_mstats|||
dump_packsubs||5.006000|
dump_sub||5.006000|
dump_vindent||5.006000|
dumpuntil|||
dup_attrlist|||
emulate_eaccess|||
eval_pv|5.006000||p
eval_sv|5.006000||p
expect_number|||
fbm_compile||5.005000|
fbm_instr||5.005000|
fd_on_nosuid_fs|||
filter_add|||
filter_del|||
filter_gets|||
filter_read|||
find_beginning|||
find_byclass|||
find_in_my_stash|||
find_runcv|||
find_rundefsvoffset||5.009002|
find_script|||
find_uninit_var|||
fold_constants|||
forbid_setid|||
force_ident|||
force_list|||
force_next|||
force_version|||
force_word|||
form_nocontext|||vn
form||5.004000|v
fp_dup|||
fprintf_nocontext|||vn
free_global_struct|||
free_tied_hv_pool|||
free_tmps|||
gen_constant_list|||
get_av|5.006000||p
get_context||5.006000|n
get_cv|5.006000||p
get_db_sub|||
get_debug_opts|||
get_hash_seed|||
get_hv|5.006000||p
get_mstats|||
get_no_modify|||
get_num|||
get_op_descs||5.005000|
get_op_names||5.005000|
get_opargs|||
get_ppaddr||5.006000|
get_sv|5.006000||p
get_vtbl||5.005030|
getcwd_sv||5.007002|
getenv_len|||
gp_dup|||
gp_free|||
gp_ref|||
grok_bin|5.007003||p
grok_hex|5.007003||p
grok_number|5.007002||p
grok_numeric_radix|5.007002||p
grok_oct|5.007003||p
group_end|||
gv_AVadd|||
gv_HVadd|||
gv_IOadd|||
gv_autoload4||5.004000|
gv_check|||
gv_dump||5.006000|
gv_efullname3||5.004000|
gv_efullname4||5.006001|
gv_efullname|||
gv_ename|||
gv_fetchfile|||
gv_fetchmeth_autoload||5.007003|
gv_fetchmethod_autoload||5.004000|
gv_fetchmethod|||
gv_fetchmeth|||
gv_fetchpvn_flags||5.009002|
gv_fetchpv|||
gv_fetchsv||5.009002|
gv_fullname3||5.004000|
gv_fullname4||5.006001|
gv_fullname|||
gv_handler||5.007001|
gv_init_sv|||
gv_init|||
gv_share|||
gv_stashpvn|5.006000||p
gv_stashpv|||
gv_stashsv|||
he_dup|||
hek_dup|||
hfreeentries|||
hsplit|||
hv_assert||5.009001|
hv_auxinit|||
hv_clear_placeholders||5.009001|
hv_clear|||
hv_delayfree_ent||5.004000|
hv_delete_common|||
hv_delete_ent||5.004000|
hv_delete|||
hv_eiter_p||5.009003|
hv_eiter_set||5.009003|
hv_exists_ent||5.004000|
hv_exists|||
hv_fetch_common|||
hv_fetch_ent||5.004000|
hv_fetch|||
hv_free_ent||5.004000|
hv_iterinit|||
hv_iterkeysv||5.004000|
hv_iterkey|||
hv_iternext_flags||5.008000|
hv_iternextsv|||
hv_iternext|||
hv_iterval|||
hv_ksplit||5.004000|
hv_magic_check|||
hv_magic|||
hv_name_set||5.009003|
hv_notallowed|||
hv_placeholders_get||5.009003|
hv_placeholders_p||5.009003|
hv_placeholders_set||5.009003|
hv_riter_p||5.009003|
hv_riter_set||5.009003|
hv_scalar||5.009001|
hv_store_ent||5.004000|
hv_store_flags||5.008000|
hv_store|||
hv_undef|||
ibcmp_locale||5.004000|
ibcmp_utf8||5.007003|
ibcmp|||
incl_perldb|||
incline|||
incpush|||
ingroup|||
init_argv_symbols|||
init_debugger|||
init_global_struct|||
init_i18nl10n||5.006000|
init_i18nl14n||5.006000|
init_ids|||
init_interp|||
init_lexer|||
init_main_stash|||
init_perllib|||
init_postdump_symbols|||
init_predump_symbols|||
init_stacks||5.005000|
init_tm||5.007002|
instr|||
intro_my|||
intuit_method|||
intuit_more|||
invert|||
io_close|||
isALNUM|||
isALPHA|||
isDIGIT|||
isLOWER|||
isSPACE|||
isUPPER|||
is_an_int|||
is_gv_magical_sv|||
is_gv_magical|||
is_handle_constructor|||
is_list_assignment|||
is_lvalue_sub||5.007001|
is_uni_alnum_lc||5.006000|
is_uni_alnumc_lc||5.006000|
is_uni_alnumc||5.006000|
is_uni_alnum||5.006000|
is_uni_alpha_lc||5.006000|
is_uni_alpha||5.006000|
is_uni_ascii_lc||5.006000|
is_uni_ascii||5.006000|
is_uni_cntrl_lc||5.006000|
is_uni_cntrl||5.006000|
is_uni_digit_lc||5.006000|
is_uni_digit||5.006000|
is_uni_graph_lc||5.006000|
is_uni_graph||5.006000|
is_uni_idfirst_lc||5.006000|
is_uni_idfirst||5.006000|
is_uni_lower_lc||5.006000|
is_uni_lower||5.006000|
is_uni_print_lc||5.006000|
is_uni_print||5.006000|
is_uni_punct_lc||5.006000|
is_uni_punct||5.006000|
is_uni_space_lc||5.006000|
is_uni_space||5.006000|
is_uni_upper_lc||5.006000|
is_uni_upper||5.006000|
is_uni_xdigit_lc||5.006000|
is_uni_xdigit||5.006000|
is_utf8_alnumc||5.006000|
is_utf8_alnum||5.006000|
is_utf8_alpha||5.006000|
is_utf8_ascii||5.006000|
is_utf8_char_slow|||
is_utf8_char||5.006000|
is_utf8_cntrl||5.006000|
is_utf8_digit||5.006000|
is_utf8_graph||5.006000|
is_utf8_idcont||5.008000|
is_utf8_idfirst||5.006000|
is_utf8_lower||5.006000|
is_utf8_mark||5.006000|
is_utf8_print||5.006000|
is_utf8_punct||5.006000|
is_utf8_space||5.006000|
is_utf8_string_loclen||5.009003|
is_utf8_string_loc||5.008001|
is_utf8_string||5.006001|
is_utf8_upper||5.006000|
is_utf8_xdigit||5.006000|
isa_lookup|||
items|||n
ix|||n
jmaybe|||
keyword|||
leave_scope|||
lex_end|||
lex_start|||
linklist|||
listkids|||
list|||
load_module_nocontext|||vn
load_module||5.006000|v
localize|||
looks_like_number|||
lop|||
mPUSHi|5.009002||p
mPUSHn|5.009002||p
mPUSHp|5.009002||p
mPUSHu|5.009002||p
mXPUSHi|5.009002||p
mXPUSHn|5.009002||p
mXPUSHp|5.009002||p
mXPUSHu|5.009002||p
magic_clear_all_env|||
magic_clearenv|||
magic_clearpack|||
magic_clearsig|||
magic_dump||5.006000|
magic_existspack|||
magic_freearylen_p|||
magic_freeovrld|||
magic_freeregexp|||
magic_getarylen|||
magic_getdefelem|||
magic_getglob|||
magic_getnkeys|||
magic_getpack|||
magic_getpos|||
magic_getsig|||
magic_getsubstr|||
magic_gettaint|||
magic_getuvar|||
magic_getvec|||
magic_get|||
magic_killbackrefs|||
magic_len|||
magic_methcall|||
magic_methpack|||
magic_nextpack|||
magic_regdata_cnt|||
magic_regdatum_get|||
magic_regdatum_set|||
magic_scalarpack|||
magic_set_all_env|||
magic_setamagic|||
magic_setarylen|||
magic_setbm|||
magic_setcollxfrm|||
magic_setdbline|||
magic_setdefelem|||
magic_setenv|||
magic_setfm|||
magic_setglob|||
magic_setisa|||
magic_setmglob|||
magic_setnkeys|||
magic_setpack|||
magic_setpos|||
magic_setregexp|||
magic_setsig|||
magic_setsubstr|||
magic_settaint|||
magic_setutf8|||
magic_setuvar|||
magic_setvec|||
magic_set|||
magic_sizepack|||
magic_wipepack|||
magicname|||
make_trie|||
malloced_size|||n
malloc||5.007002|n
markstack_grow|||
measure_struct|||
memEQ|5.004000||p
memNE|5.004000||p
mem_collxfrm|||
mess_alloc|||
mess_nocontext|||vn
mess||5.006000|v
method_common|||
mfree||5.007002|n
mg_clear|||
mg_copy|||
mg_dup|||
mg_find|||
mg_free|||
mg_get|||
mg_length||5.005000|
mg_localize|||
mg_magical|||
mg_set|||
mg_size||5.005000|
mini_mktime||5.007002|
missingterm|||
mode_from_discipline|||
modkids|||
mod|||
moreswitches|||
mul128|||
mulexp10|||n
my_atof2||5.007002|
my_atof||5.006000|
my_attrs|||
my_bcopy|||n
my_betoh16|||n
my_betoh32|||n
my_betoh64|||n
my_betohi|||n
my_betohl|||n
my_betohs|||n
my_bzero|||n
my_chsize|||
my_exit_jump|||
my_exit|||
my_failure_exit||5.004000|
my_fflush_all||5.006000|
my_fork||5.007003|n
my_htobe16|||n
my_htobe32|||n
my_htobe64|||n
my_htobei|||n
my_htobel|||n
my_htobes|||n
my_htole16|||n
my_htole32|||n
my_htole64|||n
my_htolei|||n
my_htolel|||n
my_htoles|||n
my_htonl|||
my_kid|||
my_letoh16|||n
my_letoh32|||n
my_letoh64|||n
my_letohi|||n
my_letohl|||n
my_letohs|||n
my_lstat|||
my_memcmp||5.004000|n
my_memset|||n
my_ntohl|||
my_pclose||5.004000|
my_popen_list||5.007001|
my_popen||5.004000|
my_setenv|||
my_socketpair||5.007003|n
my_stat|||
my_strftime||5.007002|
my_swabn|||n
my_swap|||
my_unexec|||
my|||
newANONATTRSUB||5.006000|
newANONHASH|||
newANONLIST|||
newANONSUB|||
newASSIGNOP|||
newATTRSUB||5.006000|
newAVREF|||
newAV|||
newBINOP|||
newCONDOP|||
newCONSTSUB|5.006000||p
newCVREF|||
newDEFSVOP|||
newFORM|||
newFOROP|||
newGVOP|||
newGVREF|||
newGVgen|||
newHVREF|||
newHVhv||5.005000|
newHV|||
newIO|||
newLISTOP|||
newLOGOP|||
newLOOPEX|||
newLOOPOP|||
newMYSUB||5.006000|
newNULLLIST|||
newOP|||
newPADOP||5.006000|
newPMOP|||
newPROG|||
newPVOP|||
newRANGE|||
newRV_inc|5.004000||p
newRV_noinc|5.006000||p
newRV|||
newSLICEOP|||
newSTATEOP|||
newSUB|||
newSVOP|||
newSVREF|||
newSVhek||5.009003|
newSViv|||
newSVnv|||
newSVpvf_nocontext|||vn
newSVpvf||5.004000|v
newSVpvn_share||5.007001|
newSVpvn|5.006000||p
newSVpv|||
newSVrv|||
newSVsv|||
newSVuv|5.006000||p
newSV|||
newUNOP|||
newWHILEOP||5.009003|
newXSproto||5.006000|
newXS||5.006000|
new_collate||5.006000|
new_constant|||
new_ctype||5.006000|
new_he|||
new_logop|||
new_numeric||5.006000|
new_stackinfo||5.005000|
new_version||5.009000|
next_symbol|||
nextargv|||
nextchar|||
ninstr|||
no_bareword_allowed|||
no_fh_allowed|||
no_op|||
not_a_number|||
nothreadhook||5.008000|
nuke_stacks|||
num_overflow|||n
oopsAV|||
oopsCV|||
oopsHV|||
op_clear|||
op_const_sv|||
op_dump||5.006000|
op_free|||
op_null||5.007002|
op_refcnt_lock||5.009002|
op_refcnt_unlock||5.009002|
open_script|||
pMY_CXT_|5.007003||p
pMY_CXT|5.007003||p
pTHX_|5.006000||p
pTHX|5.006000||p
pack_cat||5.007003|
pack_rec|||
package|||
packlist||5.008001|
pad_add_anon|||
pad_add_name|||
pad_alloc|||
pad_block_start|||
pad_check_dup|||
pad_compname_type|||
pad_findlex|||
pad_findmy|||
pad_fixup_inner_anons|||
pad_free|||
pad_leavemy|||
pad_new|||
pad_push|||
pad_reset|||
pad_setsv|||
pad_sv|||
pad_swipe|||
pad_tidy|||
pad_undef|||
parse_body|||
parse_unicode_opts|||
path_is_absolute|||
peep|||
pending_ident|||
perl_alloc_using|||n
perl_alloc|||n
perl_clone_using|||n
perl_clone|||n
perl_construct|||n
perl_destruct||5.007003|n
perl_free|||n
perl_parse||5.006000|n
perl_run|||n
pidgone|||
pmflag|||
pmop_dump||5.006000|
pmruntime|||
pmtrans|||
pop_scope|||
pregcomp|||
pregexec|||
pregfree|||
prepend_elem|||
printf_nocontext|||vn
ptr_table_clear|||
ptr_table_fetch|||
ptr_table_free|||
ptr_table_new|||
ptr_table_split|||
ptr_table_store|||
push_scope|||
put_byte|||
pv_display||5.006000|
pv_uni_display||5.007003|
qerror|||
re_croak2|||
re_dup|||
re_intuit_start||5.006000|
re_intuit_string||5.006000|
realloc||5.007002|n
reentrant_free|||
reentrant_init|||
reentrant_retry|||vn
reentrant_size|||
refkids|||
refto|||
ref|||
reg_node|||
reganode|||
regatom|||
regbranch|||
regclass_swash||5.007003|
regclass|||
regcp_set_to|||
regcppop|||
regcppush|||
regcurly|||
regdump||5.005000|
regexec_flags||5.005000|
reghop3|||
reghopmaybe3|||
reghopmaybe|||
reghop|||
reginclass|||
reginitcolors||5.006000|
reginsert|||
regmatch|||
regnext||5.005000|
regoptail|||
regpiece|||
regpposixcc|||
regprop|||
regrepeat_hard|||
regrepeat|||
regtail|||
regtry|||
reguni|||
regwhite|||
reg|||
repeatcpy|||
report_evil_fh|||
report_uninit|||
require_errno|||
require_pv||5.006000|
rninstr|||
rsignal_restore|||
rsignal_save|||
rsignal_state||5.004000|
rsignal||5.004000|
run_body|||
runops_debug||5.005000|
runops_standard||5.005000|
rvpv_dup|||
rxres_free|||
rxres_restore|||
rxres_save|||
safesyscalloc||5.006000|n
safesysfree||5.006000|n
safesysmalloc||5.006000|n
safesysrealloc||5.006000|n
same_dirent|||
save_I16||5.004000|
save_I32|||
save_I8||5.006000|
save_aelem||5.004050|
save_alloc||5.006000|
save_aptr|||
save_ary|||
save_bool||5.008001|
save_clearsv|||
save_delete|||
save_destructor_x||5.006000|
save_destructor||5.006000|
save_freeop|||
save_freepv|||
save_freesv|||
save_generic_pvref||5.006001|
save_generic_svref||5.005030|
save_gp||5.004000|
save_hash|||
save_hek_flags|||
save_helem||5.004050|
save_hints||5.005000|
save_hptr|||
save_int|||
save_item|||
save_iv||5.005000|
save_lines|||
save_list|||
save_long|||
save_magic|||
save_mortalizesv||5.007001|
save_nogv|||
save_op|||
save_padsv||5.007001|
save_pptr|||
save_re_context||5.006000|
save_scalar_at|||
save_scalar|||
save_set_svflags||5.009000|
save_shared_pvref||5.007003|
save_sptr|||
save_svref|||
save_threadsv||5.005000|
save_vptr||5.006000|
savepvn|||
savepv|||
savesharedpv||5.007003|
savestack_grow_cnt||5.008001|
savestack_grow|||
savesvpv||5.009002|
sawparens|||
scalar_mod_type|||
scalarboolean|||
scalarkids|||
scalarseq|||
scalarvoid|||
scalar|||
scan_bin||5.006000|
scan_commit|||
scan_const|||
scan_formline|||
scan_heredoc|||
scan_hex|||
scan_ident|||
scan_inputsymbol|||
scan_num||5.007001|
scan_oct|||
scan_pat|||
scan_str|||
scan_subst|||
scan_trans|||
scan_version||5.009001|
scan_vstring||5.008001|
scan_word|||
scope|||
screaminstr||5.005000|
seed|||
set_context||5.006000|n
set_csh|||
set_numeric_local||5.006000|
set_numeric_radix||5.006000|
set_numeric_standard||5.006000|
setdefout|||
setenv_getix|||
share_hek_flags|||
share_hek|||
si_dup|||
sighandler|||n
simplify_sort|||
skipspace|||
sortsv||5.007003|
ss_dup|||
stack_grow|||
start_glob|||
start_subparse||5.004000|
stashpv_hvname_match||5.009003|
stdize_locale|||
strEQ|||
strGE|||
strGT|||
strLE|||
strLT|||
strNE|||
str_to_version||5.006000|
strnEQ|||
strnNE|||
study_chunk|||
sub_crush_depth|||
sublex_done|||
sublex_push|||
sublex_start|||
sv_2bool|||
sv_2cv|||
sv_2io|||
sv_2iuv_non_preserve|||
sv_2iv_flags||5.009001|
sv_2iv|||
sv_2mortal|||
sv_2nv|||
sv_2pv_flags||5.007002|
sv_2pv_nolen|5.006000||p
sv_2pvbyte_nolen|||
sv_2pvbyte|5.006000||p
sv_2pvutf8_nolen||5.006000|
sv_2pvutf8||5.006000|
sv_2pv|||
sv_2uv_flags||5.009001|
sv_2uv|5.004000||p
sv_add_arena|||
sv_add_backref|||
sv_backoff|||
sv_bless|||
sv_cat_decode||5.008001|
sv_catpv_mg|5.006000||p
sv_catpvf_mg_nocontext|||pvn
sv_catpvf_mg|5.006000|5.004000|pv
sv_catpvf_nocontext|||vn
sv_catpvf||5.004000|v
sv_catpvn_flags||5.007002|
sv_catpvn_mg|5.006000||p
sv_catpvn_nomg|5.007002||p
sv_catpvn|||
sv_catpv|||
sv_catsv_flags||5.007002|
sv_catsv_mg|5.006000||p
sv_catsv_nomg|5.007002||p
sv_catsv|||
sv_chop|||
sv_clean_all|||
sv_clean_objs|||
sv_clear|||
sv_cmp_locale||5.004000|
sv_cmp|||
sv_collxfrm|||
sv_compile_2op||5.008001|
sv_copypv||5.007003|
sv_dec|||
sv_del_backref|||
sv_derived_from||5.004000|
sv_dump|||
sv_dup|||
sv_eq|||
sv_force_normal_flags||5.007001|
sv_force_normal||5.006000|
sv_free2|||
sv_free_arenas|||
sv_free|||
sv_gets||5.004000|
sv_grow|||
sv_inc|||
sv_insert|||
sv_isa|||
sv_isobject|||
sv_iv||5.005000|
sv_len_utf8||5.006000|
sv_len|||
sv_magicext||5.007003|
sv_magic|||
sv_mortalcopy|||
sv_newmortal|||
sv_newref|||
sv_nolocking||5.007003|
sv_nosharing||5.007003|
sv_nounlocking||5.007003|
sv_nv||5.005000|
sv_peek||5.005000|
sv_pos_b2u||5.006000|
sv_pos_u2b||5.006000|
sv_pvbyten_force||5.006000|
sv_pvbyten||5.006000|
sv_pvbyte||5.006000|
sv_pvn_force_flags||5.007002|
sv_pvn_force|||p
sv_pvn_nomg|5.007003||p
sv_pvn|5.006000||p
sv_pvutf8n_force||5.006000|
sv_pvutf8n||5.006000|
sv_pvutf8||5.006000|
sv_pv||5.006000|
sv_recode_to_utf8||5.007003|
sv_reftype|||
sv_release_COW|||
sv_release_IVX|||
sv_replace|||
sv_report_used|||
sv_reset|||
sv_rvweaken||5.006000|
sv_setiv_mg|5.006000||p
sv_setiv|||
sv_setnv_mg|5.006000||p
sv_setnv|||
sv_setpv_mg|5.006000||p
sv_setpvf_mg_nocontext|||pvn
sv_setpvf_mg|5.006000|5.004000|pv
sv_setpvf_nocontext|||vn
sv_setpvf||5.004000|v
sv_setpviv_mg||5.008001|
sv_setpviv||5.008001|
sv_setpvn_mg|5.006000||p
sv_setpvn|||
sv_setpv|||
sv_setref_iv|||
sv_setref_nv|||
sv_setref_pvn|||
sv_setref_pv|||
sv_setref_uv||5.007001|
sv_setsv_cow|||
sv_setsv_flags||5.007002|
sv_setsv_mg|5.006000||p
sv_setsv_nomg|5.007002||p
sv_setsv|||
sv_setuv_mg|5.006000||p
sv_setuv|5.006000||p
sv_tainted||5.004000|
sv_taint||5.004000|
sv_true||5.005000|
sv_unglob|||
sv_uni_display||5.007003|
sv_unmagic|||
sv_unref_flags||5.007001|
sv_unref|||
sv_untaint||5.004000|
sv_upgrade|||
sv_usepvn_mg|5.006000||p
sv_usepvn|||
sv_utf8_decode||5.006000|
sv_utf8_downgrade||5.006000|
sv_utf8_encode||5.006000|
sv_utf8_upgrade_flags||5.007002|
sv_utf8_upgrade||5.007001|
sv_uv|5.006000||p
sv_vcatpvf_mg|5.006000|5.004000|p
sv_vcatpvfn||5.004000|
sv_vcatpvf|5.006000|5.004000|p
sv_vsetpvf_mg|5.006000|5.004000|p
sv_vsetpvfn||5.004000|
sv_vsetpvf|5.006000|5.004000|p
svtype|||
swallow_bom|||
swash_fetch||5.007002|
swash_init||5.006000|
sys_intern_clear|||
sys_intern_dup|||
sys_intern_init|||
taint_env|||
taint_proper|||
tmps_grow||5.006000|
toLOWER|||
toUPPER|||
to_byte_substr|||
to_uni_fold||5.007003|
to_uni_lower_lc||5.006000|
to_uni_lower||5.007003|
to_uni_title_lc||5.006000|
to_uni_title||5.007003|
to_uni_upper_lc||5.006000|
to_uni_upper||5.007003|
to_utf8_case||5.007003|
to_utf8_fold||5.007003|
to_utf8_lower||5.007003|
to_utf8_substr|||
to_utf8_title||5.007003|
to_utf8_upper||5.007003|
tokeq|||
tokereport|||
too_few_arguments|||
too_many_arguments|||
unlnk|||
unpack_rec|||
unpack_str||5.007003|
unpackstring||5.008001|
unshare_hek_or_pvn|||
unshare_hek|||
unsharepvn||5.004000|
upg_version||5.009000|
usage|||
utf16_textfilter|||
utf16_to_utf8_reversed||5.006001|
utf16_to_utf8||5.006001|
utf16rev_textfilter|||
utf8_distance||5.006000|
utf8_hop||5.006000|
utf8_length||5.007001|
utf8_mg_pos_init|||
utf8_mg_pos|||
utf8_to_bytes||5.006001|
utf8_to_uvchr||5.007001|
utf8_to_uvuni||5.007001|
utf8n_to_uvchr||5.007001|
utf8n_to_uvuni||5.007001|
utilize|||
uvchr_to_utf8_flags||5.007003|
uvchr_to_utf8||5.007001|
uvuni_to_utf8_flags||5.007003|
uvuni_to_utf8||5.007001|
validate_suid|||
varname|||
vcmp||5.009000|
vcroak||5.006000|
vdeb||5.007003|
vdie|||
vform||5.006000|
visit|||
vivify_defelem|||
vivify_ref|||
vload_module||5.006000|
vmess||5.006000|
vnewSVpvf|5.006000|5.004000|p
vnormal||5.009002|
vnumify||5.009000|
vstringify||5.009000|
vwarner||5.006000|
vwarn||5.006000|
wait4pid|||
warn_nocontext|||vn
warner_nocontext|||vn
warner||5.006000|v
warn|||v
watch|||
whichsig|||
write_to_stderr|||
yyerror|||
yylex|||
yyparse|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %depends);
my $replace = 0;
my $hint = '';
while (<DATA>) {
if ($hint) {
if (m{^\s*\*\s(.*?)\s*$}) {
$hints{$hint} ||= ''; # suppress warning with older perls
$hints{$hint} .= "$1\n";
}
else {
$hint = '';
}
}
$hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
$replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
$replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
$replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
$replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
}
$need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
}
if (exists $opt{'api-info'}) {
my $f;
my $count = 0;
my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $f =~ /$match/;
print "\n=== $f ===\n\n";
my $info = 0;
if ($API{$f}{base} || $API{$f}{todo}) {
my $base = format_version($API{$f}{base} || $API{$f}{todo});
print "Supported at least starting from perl-$base.\n";
$info++;
}
if ($API{$f}{provided}) {
my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
print "Support by $ppport provided back to perl-$todo.\n";
print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
print "$hints{$f}" if exists $hints{$f};
$info++;
}
unless ($info) {
print "No portability information available.\n";
}
$count++;
}
if ($count > 0) {
print "\n";
}
else {
print "Found no API matching '$opt{'api-info'}'.\n";
}
exit 0;
}
if (exists $opt{'list-provided'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{provided};
my @flags;
push @flags, 'explicit' if exists $need{$f};
push @flags, 'depend' if exists $depends{$f};
push @flags, 'hint' if exists $hints{$f};
my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
print "$f$flags\n";
}
exit 0;
}
my @files;
my @srcext = qw( xs c h cc cpp );
my $srcext = join '|', @srcext;
if (@ARGV) {
my %seen;
@files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /\.($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*.$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
my(@in, @out);
my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
for (@files) {
my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i;
push @{ $out ? \@out : \@in }, $_;
}
if (@ARGV && @out) {
warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
}
@files = @in;
}
unless (@files) {
die "No input files given!\n";
}
my(%files, %global, %revreplace);
%revreplace = reverse %replace;
my $filename;
my $patch_opened = 0;
for $filename (@files) {
unless (open IN, "<$filename") {
warn "Unable to read from $filename: $!\n";
next;
}
info("Scanning $filename ...");
my $c = do { local $/; <IN> };
close IN;
my %file = (orig => $c, changes => 0);
# temporarily remove C comments from the code
my @ccom;
$c =~ s{
(
[^"'/]+
|
(?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
|
(?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
)
|
(/ (?:
\*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
|
/[^\r\n]*
))
}{
defined $2 and push @ccom, $2;
defined $1 ? $1 : "$ccs$#ccom$cce";
}egsx;
$file{ccom} = \@ccom;
$file{code} = $c;
$file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
my $func;
for $func (keys %API) {
my $match = $func;
$match .= "|$revreplace{$func}" if exists $revreplace{$func};
if ($c =~ /\b(?:Perl_)?($match)\b/) {
$file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
$file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
if (exists $API{$func}{provided}) {
if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
$file{uses}{$func}++;
my @deps = rec_depend($func);
if (@deps) {
$file{uses_deps}{$func} = \@deps;
for (@deps) {
$file{uses}{$_} = 0 unless exists $file{uses}{$_};
}
}
for ($func, @deps) {
if (exists $need{$_}) {
$file{needs}{$_} = 'static';
}
}
}
}
if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
if ($c =~ /\b$func\b/) {
$file{uses_todo}{$func}++;
}
}
}
}
while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
if (exists $need{$2}) {
$file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
}
else {
warning("Possibly wrong #define $1 in $filename");
}
}
for (qw(uses needs uses_todo needed_global needed_static)) {
for $func (keys %{$file{$_}}) {
push @{$global{$_}{$func}}, $filename;
}
}
$files{$filename} = \%file;
}
# Globally resolve NEED_'s
my $need;
for $need (keys %{$global{needs}}) {
if (@{$global{needs}{$need}} > 1) {
my @targets = @{$global{needs}{$need}};
my @t = grep $files{$_}{needed_global}{$need}, @targets;
@targets = @t if @t;
@t = grep /\.xs$/i, @targets;
@targets = @t if @t;
my $target = shift @targets;
$files{$target}{needs}{$need} = 'global';
for (@{$global{needs}{$need}}) {
$files{$_}{needs}{$need} = 'extern' if $_ ne $target;
}
}
}
for $filename (@files) {
exists $files{$filename} or next;
info("=== Analyzing $filename ===");
my %file = %{$files{$filename}};
my $func;
my $c = $file{code};
for $func (sort keys %{$file{uses_Perl}}) {
if ($API{$func}{varargs}) {
my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
{ $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
if ($changes) {
warning("Doesn't pass interpreter argument aTHX to Perl_$func");
$file{changes} += $changes;
}
}
else {
warning("Uses Perl_$func instead of $func");
$file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
{$func$1(}g);
}
}
for $func (sort keys %{$file{uses_replace}}) {
warning("Uses $func instead of $replace{$func}");
$file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
}
for $func (sort keys %{$file{uses}}) {
next unless $file{uses}{$func}; # if it's only a dependency
if (exists $file{uses_deps}{$func}) {
diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
}
elsif (exists $replace{$func}) {
warning("Uses $func instead of $replace{$func}");
$file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
}
else {
diag("Uses $func");
}
hint($func);
}
for $func (sort keys %{$file{uses_todo}}) {
warning("Uses $func, which may not be portable below perl ",
format_version($API{$func}{todo}));
}
for $func (sort keys %{$file{needed_static}}) {
my $message = '';
if (not exists $file{uses}{$func}) {
$message = "No need to define NEED_$func if $func is never used";
}
elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
$message = "No need to define NEED_$func when already needed globally";
}
if ($message) {
diag($message);
$file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
}
}
for $func (sort keys %{$file{needed_global}}) {
my $message = '';
if (not exists $global{uses}{$func}) {
$message = "No need to define NEED_${func}_GLOBAL if $func is never used";
}
elsif (exists $file{needs}{$func}) {
if ($file{needs}{$func} eq 'extern') {
$message = "No need to define NEED_${func}_GLOBAL when already needed globally";
}
elsif ($file{needs}{$func} eq 'static') {
$message = "No need to define NEED_${func}_GLOBAL when only used in this file";
}
}
if ($message) {
diag($message);
$file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
}
}
$file{needs_inc_ppport} = keys %{$file{uses}};
if ($file{needs_inc_ppport}) {
my $pp = '';
for $func (sort keys %{$file{needs}}) {
my $type = $file{needs}{$func};
next if $type eq 'extern';
my $suffix = $type eq 'global' ? '_GLOBAL' : '';
unless (exists $file{"needed_$type"}{$func}) {
if ($type eq 'global') {
diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
}
else {
diag("File needs $func, adding static request");
}
$pp .= "#define NEED_$func$suffix\n";
}
}
if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
$pp = '';
$file{changes}++;
}
unless ($file{has_inc_ppport}) {
diag("Needs to include '$ppport'");
$pp .= qq(#include "$ppport"\n)
}
if ($pp) {
$file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
|| ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
|| ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
|| ($c =~ s/^/$pp/);
}
}
else {
if ($file{has_inc_ppport}) {
diag("No need to include '$ppport'");
$file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
}
}
# put back in our C comments
my $ix;
my $cppc = 0;
my @ccom = @{$file{ccom}};
for $ix (0 .. $#ccom) {
if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
$cppc++;
$file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
}
else {
$c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
}
}
if ($cppc) {
my $s = $cppc != 1 ? 's' : '';
warning("Uses $cppc C++ style comment$s, which is not portable");
}
if ($file{changes}) {
if (exists $opt{copy}) {
my $newfile = "$filename$opt{copy}";
if (-e $newfile) {
error("'$newfile' already exists, refusing to write copy of '$filename'");
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
}
}
elsif (exists $opt{patch} || $opt{changes}) {
if (exists $opt{patch}) {
unless ($patch_opened) {
if (open PATCH, ">$opt{patch}") {
$patch_opened = 1;
}
else {
error("Cannot open '$opt{patch}' for writing: $!");
delete $opt{patch};
$opt{changes} = 1;
goto fallback;
}
}
mydiff(\*PATCH, $filename, $c);
}
else {
fallback:
info("Suggested changes:");
mydiff(\*STDOUT, $filename, $c);
}
}
else {
my $s = $file{changes} == 1 ? '' : 's';
info("$file{changes} potentially required change$s detected");
}
}
else {
info("Looks good");
}
}
close PATCH if $patch_opened;
exit 0;
sub mydiff
{
local *F = shift;
my($file, $str) = @_;
my $diff;
if (exists $opt{diff}) {
$diff = run_diff($opt{diff}, $file, $str);
}
if (!defined $diff and can_use('Text::Diff')) {
$diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
$diff = <<HEADER . $diff;
--- $file
+++ $file.patched
HEADER
}
if (!defined $diff) {
$diff = run_diff('diff -u', $file, $str);
}
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
}
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub can_use
{
eval "use @_;";
return $@ eq '';
}
sub rec_depend
{
my $func = shift;
my %seen;
return () unless exists $depends{$func};
grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
elsif ($ver !~ /^\d+\.[\d_]+$/) {
die "cannot parse version '$ver'\n";
}
$ver =~ s/_//g;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "cannot parse version '$ver'\n";
}
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "invalid version '$ver'\n";
}
$s /= 10;
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
sub hint
{
$opt{quiet} and return;
$opt{hints} or return;
my $func = shift;
exists $hints{$func} or return;
$given_hints{$func}++ and return;
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
See perldoc $0 for details.
ENDUSAGE
exit 2;
}
__DATA__
*/
#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_
#ifndef DPPP_NAMESPACE
# define DPPP_NAMESPACE DPPP_
#endif
#define DPPP_CAT2(x,y) CAT2(x,y)
#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
#ifndef PERL_REVISION
# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
# define PERL_PATCHLEVEL_H_IMPLICIT
# include <patchlevel.h>
# endif
# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
# include <could_not_find_Perl_patchlevel.h>
# endif
# ifndef PERL_REVISION
# define PERL_REVISION (5)
/* Replace: 1 */
# define PERL_VERSION PATCHLEVEL
# define PERL_SUBVERSION SUBVERSION
/* Replace PERL_PATCHLEVEL with PERL_VERSION */
/* Replace: 0 */
# endif
#endif
#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
/* It is very unlikely that anyone will try to use this with Perl 6
(or greater), but who knows.
*/
#if PERL_REVISION != 5
# error ppport.h only works with Perl version 5
#endif /* PERL_REVISION != 5 */
#ifdef I_LIMITS
# include <limits.h>
#endif
#ifndef PERL_UCHAR_MIN
# define PERL_UCHAR_MIN ((unsigned char)0)
#endif
#ifndef PERL_UCHAR_MAX
# ifdef UCHAR_MAX
# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
# else
# ifdef MAXUCHAR
# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
# else
# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
# endif
# endif
#endif
#ifndef PERL_USHORT_MIN
# define PERL_USHORT_MIN ((unsigned short)0)
#endif
#ifndef PERL_USHORT_MAX
# ifdef USHORT_MAX
# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
# else
# ifdef MAXUSHORT
# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
# else
# ifdef USHRT_MAX
# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
# else
# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
# endif
# endif
# endif
#endif
#ifndef PERL_SHORT_MAX
# ifdef SHORT_MAX
# define PERL_SHORT_MAX ((short)SHORT_MAX)
# else
# ifdef MAXSHORT /* Often used in <values.h> */
# define PERL_SHORT_MAX ((short)MAXSHORT)
# else
# ifdef SHRT_MAX
# define PERL_SHORT_MAX ((short)SHRT_MAX)
# else
# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
# endif
# endif
# endif
#endif
#ifndef PERL_SHORT_MIN
# ifdef SHORT_MIN
# define PERL_SHORT_MIN ((short)SHORT_MIN)
# else
# ifdef MINSHORT
# define PERL_SHORT_MIN ((short)MINSHORT)
# else
# ifdef SHRT_MIN
# define PERL_SHORT_MIN ((short)SHRT_MIN)
# else
# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
# endif
# endif
# endif
#endif
#ifndef PERL_UINT_MAX
# ifdef UINT_MAX
# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
# else
# ifdef MAXUINT
# define PERL_UINT_MAX ((unsigned int)MAXUINT)
# else
# define PERL_UINT_MAX (~(unsigned int)0)
# endif
# endif
#endif
#ifndef PERL_UINT_MIN
# define PERL_UINT_MIN ((unsigned int)0)
#endif
#ifndef PERL_INT_MAX
# ifdef INT_MAX
# define PERL_INT_MAX ((int)INT_MAX)
# else
# ifdef MAXINT /* Often used in <values.h> */
# define PERL_INT_MAX ((int)MAXINT)
# else
# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
# endif
# endif
#endif
#ifndef PERL_INT_MIN
# ifdef INT_MIN
# define PERL_INT_MIN ((int)INT_MIN)
# else
# ifdef MININT
# define PERL_INT_MIN ((int)MININT)
# else
# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
# endif
# endif
#endif
#ifndef PERL_ULONG_MAX
# ifdef ULONG_MAX
# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
# else
# ifdef MAXULONG
# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
# else
# define PERL_ULONG_MAX (~(unsigned long)0)
# endif
# endif
#endif
#ifndef PERL_ULONG_MIN
# define PERL_ULONG_MIN ((unsigned long)0L)
#endif
#ifndef PERL_LONG_MAX
# ifdef LONG_MAX
# define PERL_LONG_MAX ((long)LONG_MAX)
# else
# ifdef MAXLONG
# define PERL_LONG_MAX ((long)MAXLONG)
# else
# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
# endif
# endif
#endif
#ifndef PERL_LONG_MIN
# ifdef LONG_MIN
# define PERL_LONG_MIN ((long)LONG_MIN)
# else
# ifdef MINLONG
# define PERL_LONG_MIN ((long)MINLONG)
# else
# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
# endif
# endif
#endif
#if defined(HAS_QUAD) && (defined(convex) || defined(uts))
# ifndef PERL_UQUAD_MAX
# ifdef ULONGLONG_MAX
# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
# else
# ifdef MAXULONGLONG
# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
# else
# define PERL_UQUAD_MAX (~(unsigned long long)0)
# endif
# endif
# endif
# ifndef PERL_UQUAD_MIN
# define PERL_UQUAD_MIN ((unsigned long long)0L)
# endif
# ifndef PERL_QUAD_MAX
# ifdef LONGLONG_MAX
# define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
# else
# ifdef MAXLONGLONG
# define PERL_QUAD_MAX ((long long)MAXLONGLONG)
# else
# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
# endif
# endif
# endif
# ifndef PERL_QUAD_MIN
# ifdef LONGLONG_MIN
# define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
# else
# ifdef MINLONGLONG
# define PERL_QUAD_MIN ((long long)MINLONGLONG)
# else
# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
# endif
# endif
# endif
#endif
/* This is based on code from 5.003 perl.h */
#ifdef HAS_QUAD
# ifdef cray
#ifndef IVTYPE
# define IVTYPE int
#endif
#ifndef IV_MIN
# define IV_MIN PERL_INT_MIN
#endif
#ifndef IV_MAX
# define IV_MAX PERL_INT_MAX
#endif
#ifndef UV_MIN
# define UV_MIN PERL_UINT_MIN
#endif
#ifndef UV_MAX
# define UV_MAX PERL_UINT_MAX
#endif
# ifdef INTSIZE
#ifndef IVSIZE
# define IVSIZE INTSIZE
#endif
# endif
# else
# if defined(convex) || defined(uts)
#ifndef IVTYPE
# define IVTYPE long long
#endif
#ifndef IV_MIN
# define IV_MIN PERL_QUAD_MIN
#endif
#ifndef IV_MAX
# define IV_MAX PERL_QUAD_MAX
#endif
#ifndef UV_MIN
# define UV_MIN PERL_UQUAD_MIN
#endif
#ifndef UV_MAX
# define UV_MAX PERL_UQUAD_MAX
#endif
# ifdef LONGLONGSIZE
#ifndef IVSIZE
# define IVSIZE LONGLONGSIZE
#endif
# endif
# else
#ifndef IVTYPE
# define IVTYPE long
#endif
#ifndef IV_MIN
# define IV_MIN PERL_LONG_MIN
#endif
#ifndef IV_MAX
# define IV_MAX PERL_LONG_MAX
#endif
#ifndef UV_MIN
# define UV_MIN PERL_ULONG_MIN
#endif
#ifndef UV_MAX
# define UV_MAX PERL_ULONG_MAX
#endif
# ifdef LONGSIZE
#ifndef IVSIZE
# define IVSIZE LONGSIZE
#endif
# endif
# endif
# endif
#ifndef IVSIZE
# define IVSIZE 8
#endif
#ifndef PERL_QUAD_MIN
# define PERL_QUAD_MIN IV_MIN
#endif
#ifndef PERL_QUAD_MAX
# define PERL_QUAD_MAX IV_MAX
#endif
#ifndef PERL_UQUAD_MIN
# define PERL_UQUAD_MIN UV_MIN
#endif
#ifndef PERL_UQUAD_MAX
# define PERL_UQUAD_MAX UV_MAX
#endif
#else
#ifndef IVTYPE
# define IVTYPE long
#endif
#ifndef IV_MIN
# define IV_MIN PERL_LONG_MIN
#endif
#ifndef IV_MAX
# define IV_MAX PERL_LONG_MAX
#endif
#ifndef UV_MIN
# define UV_MIN PERL_ULONG_MIN
#endif
#ifndef UV_MAX
# define UV_MAX PERL_ULONG_MAX
#endif
#endif
#ifndef IVSIZE
# ifdef LONGSIZE
# define IVSIZE LONGSIZE
# else
# define IVSIZE 4 /* A bold guess, but the best we can make. */
# endif
#endif
#ifndef UVTYPE
# define UVTYPE unsigned IVTYPE
#endif
#ifndef UVSIZE
# define UVSIZE IVSIZE
#endif
#ifndef sv_setuv
# define sv_setuv(sv, uv) \
STMT_START { \
UV TeMpUv = uv; \
if (TeMpUv <= IV_MAX) \
sv_setiv(sv, TeMpUv); \
else \
sv_setnv(sv, (double)TeMpUv); \
} STMT_END
#endif
#ifndef newSVuv
# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
#endif
#ifndef sv_2uv
# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
#endif
#ifndef SvUVX
# define SvUVX(sv) ((UV)SvIVX(sv))
#endif
#ifndef SvUVXx
# define SvUVXx(sv) SvUVX(sv)
#endif
#ifndef SvUV
# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
#endif
#ifndef SvUVx
# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
#endif
/* Hint: sv_uv
* Always use the SvUVx() macro instead of sv_uv().
*/
#ifndef sv_uv
# define sv_uv(sv) SvUVx(sv)
#endif
#ifndef XST_mUV
# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
#endif
#ifndef XSRETURN_UV
# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
#endif
#ifndef PUSHu
# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
#endif
#ifndef XPUSHu
# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
#endif
#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
/* Replace: 1 */
# define PL_DBsingle DBsingle
# define PL_DBsub DBsub
# define PL_Sv Sv
# define PL_compiling compiling
# define PL_copline copline
# define PL_curcop curcop
# define PL_curstash curstash
# define PL_debstash debstash
# define PL_defgv defgv
# define PL_diehook diehook
# define PL_dirty dirty
# define PL_dowarn dowarn
# define PL_errgv errgv
# define PL_hexdigit hexdigit
# define PL_hints hints
# define PL_na na
# define PL_no_modify no_modify
# define PL_perl_destruct_level perl_destruct_level
# define PL_perldb perldb
# define PL_ppaddr ppaddr
# define PL_rsfp_filters rsfp_filters
# define PL_rsfp rsfp
# define PL_stack_base stack_base
# define PL_stack_sp stack_sp
# define PL_stdingv stdingv
# define PL_sv_arenaroot sv_arenaroot
# define PL_sv_no sv_no
# define PL_sv_undef sv_undef
# define PL_sv_yes sv_yes
# define PL_tainted tainted
# define PL_tainting tainting
/* Replace: 0 */
#endif
#ifndef PERL_UNUSED_DECL
# ifdef HASATTRIBUTE
# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
# define PERL_UNUSED_DECL
# else
# define PERL_UNUSED_DECL __attribute__((unused))
# endif
# else
# define PERL_UNUSED_DECL
# endif
#endif
#ifndef NOOP
# define NOOP (void)0
#endif
#ifndef dNOOP
# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
#endif
#ifndef NVTYPE
# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
# define NVTYPE long double
# else
# define NVTYPE double
# endif
typedef NVTYPE NV;
#endif
#ifndef INT2PTR
# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
# define PTRV UV
# define INT2PTR(any,d) (any)(d)
# else
# if PTRSIZE == LONGSIZE
# define PTRV unsigned long
# else
# define PTRV unsigned
# endif
# define INT2PTR(any,d) (any)(PTRV)(d)
# endif
# define NUM2PTR(any,d) (any)(PTRV)(d)
# define PTR2IV(p) INT2PTR(IV,p)
# define PTR2UV(p) INT2PTR(UV,p)
# define PTR2NV(p) NUM2PTR(NV,p)
# if PTRSIZE == LONGSIZE
# define PTR2ul(p) (unsigned long)(p)
# else
# define PTR2ul(p) INT2PTR(unsigned long,p)
# endif
#endif /* !INT2PTR */
#undef START_EXTERN_C
#undef END_EXTERN_C
#undef EXTERN_C
#ifdef __cplusplus
# define START_EXTERN_C extern "C" {
# define END_EXTERN_C }
# define EXTERN_C extern "C"
#else
# define START_EXTERN_C
# define END_EXTERN_C
# define EXTERN_C extern
#endif
#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
# endif
#endif
#undef STMT_START
#undef STMT_END
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
# define STMT_END )
#else
# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
# define STMT_START if (1)
# define STMT_END else (void)0
# else
# define STMT_START do
# define STMT_END while (0)
# endif
#endif
#ifndef boolSV
# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
#endif
/* DEFSV appears first in 5.004_56 */
#ifndef DEFSV
# define DEFSV GvSV(PL_defgv)
#endif
#ifndef SAVE_DEFSV
# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
#endif
/* Older perls (<=5.003) lack AvFILLp */
#ifndef AvFILLp
# define AvFILLp AvFILL
#endif
#ifndef ERRSV
# define ERRSV get_sv("@",FALSE)
#endif
#ifndef newSVpvn
# define newSVpvn(data,len) ((data) \
? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
: newSV(0))
#endif
/* Hint: gv_stashpvn
* This function's backport doesn't support the length parameter, but
* rather ignores it. Portability can only be ensured if the length
* parameter is used for speed reasons, but the length can always be
* correctly computed from the string argument.
*/
#ifndef gv_stashpvn
# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
#endif
/* Replace: 1 */
#ifndef get_cv
# define get_cv perl_get_cv
#endif
#ifndef get_sv
# define get_sv perl_get_sv
#endif
#ifndef get_av
# define get_av perl_get_av
#endif
#ifndef get_hv
# define get_hv perl_get_hv
#endif
/* Replace: 0 */
#ifdef HAS_MEMCMP
#ifndef memNE
# define memNE(s1,s2,l) (memcmp(s1,s2,l))
#endif
#ifndef memEQ
# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
#endif
#else
#ifndef memNE
# define memNE(s1,s2,l) (bcmp(s1,s2,l))
#endif
#ifndef memEQ
# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
#endif
#endif
#ifndef MoveD
# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
#endif
#ifndef CopyD
# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
#endif
#ifdef HAS_MEMSET
#ifndef ZeroD
# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
#endif
#else
#ifndef ZeroD
# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
#endif
#endif
#ifndef Poison
# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
#endif
#ifndef dUNDERBAR
# define dUNDERBAR dNOOP
#endif
#ifndef UNDERBAR
# define UNDERBAR DEFSV
#endif
#ifndef dAX
# define dAX I32 ax = MARK - PL_stack_base + 1
#endif
#ifndef dITEMS
# define dITEMS I32 items = SP - MARK
#endif
#ifndef dXSTARG
# define dXSTARG SV * targ = sv_newmortal()
#endif
#ifndef dTHR
# define dTHR dNOOP
#endif
#ifndef dTHX
# define dTHX dNOOP
#endif
#ifndef dTHXa
# define dTHXa(x) dNOOP
#endif
#ifndef pTHX
# define pTHX void
#endif
#ifndef pTHX_
# define pTHX_
#endif
#ifndef aTHX
# define aTHX
#endif
#ifndef aTHX_
# define aTHX_
#endif
#ifndef dTHXoa
# define dTHXoa(x) dTHXa(x)
#endif
#ifndef PUSHmortal
# define PUSHmortal PUSHs(sv_newmortal())
#endif
#ifndef mPUSHp
# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
#endif
#ifndef mPUSHn
# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
#endif
#ifndef mPUSHi
# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
#endif
#ifndef mPUSHu
# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
#endif
#ifndef XPUSHmortal
# define XPUSHmortal XPUSHs(sv_newmortal())
#endif
#ifndef mXPUSHp
# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
#endif
#ifndef mXPUSHn
# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
#endif
#ifndef mXPUSHi
# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
#endif
#ifndef mXPUSHu
# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
#endif
/* Replace: 1 */
#ifndef call_sv
# define call_sv perl_call_sv
#endif
#ifndef call_pv
# define call_pv perl_call_pv
#endif
#ifndef call_argv
# define call_argv perl_call_argv
#endif
#ifndef call_method
# define call_method perl_call_method
#endif
#ifndef eval_sv
# define eval_sv perl_eval_sv
#endif
/* Replace: 0 */
/* Replace perl_eval_pv with eval_pv */
/* eval_pv depends on eval_sv */
#ifndef eval_pv
#if defined(NEED_eval_pv)
static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
static
#else
extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
#endif
#ifdef eval_pv
# undef eval_pv
#endif
#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
#define Perl_eval_pv DPPP_(my_eval_pv)
#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
SV*
DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
{
dSP;
SV* sv = newSVpv(p, 0);
PUSHMARK(sp);
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
SPAGAIN;
sv = POPs;
PUTBACK;
if (croak_on_error && SvTRUE(GvSV(errgv)))
croak(SvPVx(GvSV(errgv), na));
return sv;
}
#endif
#endif
#ifndef newRV_inc
# define newRV_inc(sv) newRV(sv) /* Replace */
#endif
#ifndef newRV_noinc
#if defined(NEED_newRV_noinc)
static SV * DPPP_(my_newRV_noinc)(SV *sv);
static
#else
extern SV * DPPP_(my_newRV_noinc)(SV *sv);
#endif
#ifdef newRV_noinc
# undef newRV_noinc
#endif
#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
#define Perl_newRV_noinc DPPP_(my_newRV_noinc)
#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
SV *
DPPP_(my_newRV_noinc)(SV *sv)
{
SV *rv = (SV *)newRV(sv);
SvREFCNT_dec(sv);
return rv;
}
#endif
#endif
/* Hint: newCONSTSUB
* Returns a CV* as of perl-5.7.1. This return value is not supported
* by Devel::PPPort.
*/
/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
#if defined(NEED_newCONSTSUB)
static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
static
#else
extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
#endif
#ifdef newCONSTSUB
# undef newCONSTSUB
#endif
#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
void
DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
{
U32 oldhints = PL_hints;
HV *old_cop_stash = PL_curcop->cop_stash;
HV *old_curstash = PL_curstash;
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
start_subparse(),
#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
start_subparse(0),
#else /* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
newSVOP(OP_CONST, 0, newSVpv(name,0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
PL_curcop->cop_line = oldline;
}
#endif
#endif
/*
* Boilerplate macros for initializing and accessing interpreter-local
* data from C. All statics in extensions should be reworked to use
* this, if you want to make the extension thread-safe. See ext/re/re.xs
* for an example of the use of these macros.
*
* Code that uses these macros is responsible for the following:
* 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
* 2. Declare a typedef named my_cxt_t that is a structure that contains
* all the data that needs to be interpreter-local.
* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
* 4. Use the MY_CXT_INIT macro such that it is called exactly once
* (typically put in the BOOT: section).
* 5. Use the members of the my_cxt_t structure everywhere as
* MY_CXT.member.
* 6. Use the dMY_CXT macro (a declaration) in all the functions that
* access MY_CXT.
*/
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
#ifndef START_MY_CXT
/* This must appear in all extensions that define a my_cxt_t structure,
* right after the definition (i.e. at file scope). The non-threads
* case below uses it to declare the data as static. */
#define START_MY_CXT
#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
/* Fetches the SV that keeps the per-interpreter data. */
#define dMY_CXT_SV \
SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
#else /* >= perl5.004_68 */
#define dMY_CXT_SV \
SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
sizeof(MY_CXT_KEY)-1, TRUE)
#endif /* < perl5.004_68 */
/* This declaration should be used within all functions that use the
* interpreter-local data. */
#define dMY_CXT \
dMY_CXT_SV; \
my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
/* Creates and zeroes the per-interpreter data.
* (We allocate my_cxtp in a Perl SV so that it will be released when
* the interpreter goes away.) */
#define MY_CXT_INIT \
dMY_CXT_SV; \
/* newSV() allocates one more than needed */ \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
Zero(my_cxtp, 1, my_cxt_t); \
sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
/* This macro must be used to access members of the my_cxt_t structure.
* e.g. MYCXT.some_data */
#define MY_CXT (*my_cxtp)
/* Judicious use of these macros can reduce the number of times dMY_CXT
* is used. Use is similar to pTHX, aTHX etc. */
#define pMY_CXT my_cxt_t *my_cxtp
#define pMY_CXT_ pMY_CXT,
#define _pMY_CXT ,pMY_CXT
#define aMY_CXT my_cxtp
#define aMY_CXT_ aMY_CXT,
#define _aMY_CXT ,aMY_CXT
#endif /* START_MY_CXT */
#ifndef MY_CXT_CLONE
/* Clones the per-interpreter data. */
#define MY_CXT_CLONE \
dMY_CXT_SV; \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
#endif
#else /* single interpreter */
#ifndef START_MY_CXT
#define START_MY_CXT static my_cxt_t my_cxt;
#define dMY_CXT_SV dNOOP
#define dMY_CXT dNOOP
#define MY_CXT_INIT NOOP
#define MY_CXT my_cxt
#define pMY_CXT void
#define pMY_CXT_
#define _pMY_CXT
#define aMY_CXT
#define aMY_CXT_
#define _aMY_CXT
#endif /* START_MY_CXT */
#ifndef MY_CXT_CLONE
#define MY_CXT_CLONE NOOP
#endif
#endif
#ifndef IVdf
# if IVSIZE == LONGSIZE
# define IVdf "ld"
# define UVuf "lu"
# define UVof "lo"
# define UVxf "lx"
# define UVXf "lX"
# else
# if IVSIZE == INTSIZE
# define IVdf "d"
# define UVuf "u"
# define UVof "o"
# define UVxf "x"
# define UVXf "X"
# endif
# endif
#endif
#ifndef NVef
# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
# define NVef PERL_PRIeldbl
# define NVff PERL_PRIfldbl
# define NVgf PERL_PRIgldbl
# else
# define NVef "e"
# define NVff "f"
# define NVgf "g"
# endif
#endif
#ifndef SvPV_nolen
#if defined(NEED_sv_2pv_nolen)
static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
static
#else
extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
#endif
#ifdef sv_2pv_nolen
# undef sv_2pv_nolen
#endif
#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
char *
DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
{
STRLEN n_a;
return sv_2pv(sv, &n_a);
}
#endif
/* Hint: sv_2pv_nolen
* Use the SvPV_nolen() macro instead of sv_2pv_nolen().
*/
/* SvPV_nolen depends on sv_2pv_nolen */
#define SvPV_nolen(sv) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? SvPVX(sv) : sv_2pv_nolen(sv))
#endif
#ifdef SvPVbyte
/* Hint: SvPVbyte
* Does not work in perl-5.6.1, ppport.h implements a version
* borrowed from perl-5.7.3.
*/
#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
#if defined(NEED_sv_2pvbyte)
static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
static
#else
extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
#endif
#ifdef sv_2pvbyte
# undef sv_2pvbyte
#endif
#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
char *
DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
{
sv_utf8_downgrade(sv,0);
return SvPV(sv,*lp);
}
#endif
/* Hint: sv_2pvbyte
* Use the SvPVbyte() macro instead of sv_2pvbyte().
*/
#undef SvPVbyte
/* SvPVbyte depends on sv_2pvbyte */
#define SvPVbyte(sv, lp) \
((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
#endif
#else
# define SvPVbyte SvPV
# define sv_2pvbyte sv_2pv
#endif
/* sv_2pvbyte_nolen depends on sv_2pv_nolen */
#ifndef sv_2pvbyte_nolen
# define sv_2pvbyte_nolen sv_2pv_nolen
#endif
/* Hint: sv_pvn
* Always use the SvPV() macro instead of sv_pvn().
*/
#ifndef sv_pvn
# define sv_pvn(sv, len) SvPV(sv, len)
#endif
/* Hint: sv_pvn_force
* Always use the SvPV_force() macro instead of sv_pvn_force().
*/
#ifndef sv_pvn_force
# define sv_pvn_force(sv, len) SvPV_force(sv, len)
#endif
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
#if defined(NEED_vnewSVpvf)
static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
static
#else
extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
#endif
#ifdef vnewSVpvf
# undef vnewSVpvf
#endif
#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
SV *
DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
{
register SV *sv = newSV(0);
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
return sv;
}
#endif
#endif
/* sv_vcatpvf depends on sv_vcatpvfn */
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
#endif
/* sv_vsetpvf depends on sv_vsetpvfn */
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
#endif
/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
#if defined(NEED_sv_catpvf_mg)
static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
static
#else
extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
#endif
#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
void
DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
#ifdef PERL_IMPLICIT_CONTEXT
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
#if defined(NEED_sv_catpvf_mg_nocontext)
static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
static
#else
extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
#endif
#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
void
DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
#ifndef sv_catpvf_mg
# ifdef PERL_IMPLICIT_CONTEXT
# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
# else
# define sv_catpvf_mg Perl_sv_catpvf_mg
# endif
#endif
/* sv_vcatpvf_mg depends on sv_vcatpvfn */
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
# define sv_vcatpvf_mg(sv, pat, args) \
STMT_START { \
sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
SvSETMAGIC(sv); \
} STMT_END
#endif
/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
#if defined(NEED_sv_setpvf_mg)
static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
static
#else
extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
#endif
#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
void
DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
#ifdef PERL_IMPLICIT_CONTEXT
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
#if defined(NEED_sv_setpvf_mg_nocontext)
static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
static
#else
extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
#endif
#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
void
DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
#ifndef sv_setpvf_mg
# ifdef PERL_IMPLICIT_CONTEXT
# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
# else
# define sv_setpvf_mg Perl_sv_setpvf_mg
# endif
#endif
/* sv_vsetpvf_mg depends on sv_vsetpvfn */
#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
# define sv_vsetpvf_mg(sv, pat, args) \
STMT_START { \
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
SvSETMAGIC(sv); \
} STMT_END
#endif
#ifndef SvGETMAGIC
# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
#endif
#ifndef PERL_MAGIC_sv
# define PERL_MAGIC_sv '\0'
#endif
#ifndef PERL_MAGIC_overload
# define PERL_MAGIC_overload 'A'
#endif
#ifndef PERL_MAGIC_overload_elem
# define PERL_MAGIC_overload_elem 'a'
#endif
#ifndef PERL_MAGIC_overload_table
# define PERL_MAGIC_overload_table 'c'
#endif
#ifndef PERL_MAGIC_bm
# define PERL_MAGIC_bm 'B'
#endif
#ifndef PERL_MAGIC_regdata
# define PERL_MAGIC_regdata 'D'
#endif
#ifndef PERL_MAGIC_regdatum
# define PERL_MAGIC_regdatum 'd'
#endif
#ifndef PERL_MAGIC_env
# define PERL_MAGIC_env 'E'
#endif
#ifndef PERL_MAGIC_envelem
# define PERL_MAGIC_envelem 'e'
#endif
#ifndef PERL_MAGIC_fm
# define PERL_MAGIC_fm 'f'
#endif
#ifndef PERL_MAGIC_regex_global
# define PERL_MAGIC_regex_global 'g'
#endif
#ifndef PERL_MAGIC_isa
# define PERL_MAGIC_isa 'I'
#endif
#ifndef PERL_MAGIC_isaelem
# define PERL_MAGIC_isaelem 'i'
#endif
#ifndef PERL_MAGIC_nkeys
# define PERL_MAGIC_nkeys 'k'
#endif
#ifndef PERL_MAGIC_dbfile
# define PERL_MAGIC_dbfile 'L'
#endif
#ifndef PERL_MAGIC_dbline
# define PERL_MAGIC_dbline 'l'
#endif
#ifndef PERL_MAGIC_mutex
# define PERL_MAGIC_mutex 'm'
#endif
#ifndef PERL_MAGIC_shared
# define PERL_MAGIC_shared 'N'
#endif
#ifndef PERL_MAGIC_shared_scalar
# define PERL_MAGIC_shared_scalar 'n'
#endif
#ifndef PERL_MAGIC_collxfrm
# define PERL_MAGIC_collxfrm 'o'
#endif
#ifndef PERL_MAGIC_tied
# define PERL_MAGIC_tied 'P'
#endif
#ifndef PERL_MAGIC_tiedelem
# define PERL_MAGIC_tiedelem 'p'
#endif
#ifndef PERL_MAGIC_tiedscalar
# define PERL_MAGIC_tiedscalar 'q'
#endif
#ifndef PERL_MAGIC_qr
# define PERL_MAGIC_qr 'r'
#endif
#ifndef PERL_MAGIC_sig
# define PERL_MAGIC_sig 'S'
#endif
#ifndef PERL_MAGIC_sigelem
# define PERL_MAGIC_sigelem 's'
#endif
#ifndef PERL_MAGIC_taint
# define PERL_MAGIC_taint 't'
#endif
#ifndef PERL_MAGIC_uvar
# define PERL_MAGIC_uvar 'U'
#endif
#ifndef PERL_MAGIC_uvar_elem
# define PERL_MAGIC_uvar_elem 'u'
#endif
#ifndef PERL_MAGIC_vstring
# define PERL_MAGIC_vstring 'V'
#endif
#ifndef PERL_MAGIC_vec
# define PERL_MAGIC_vec 'v'
#endif
#ifndef PERL_MAGIC_utf8
# define PERL_MAGIC_utf8 'w'
#endif
#ifndef PERL_MAGIC_substr
# define PERL_MAGIC_substr 'x'
#endif
#ifndef PERL_MAGIC_defelem
# define PERL_MAGIC_defelem 'y'
#endif
#ifndef PERL_MAGIC_glob
# define PERL_MAGIC_glob '*'
#endif
#ifndef PERL_MAGIC_arylen
# define PERL_MAGIC_arylen '#'
#endif
#ifndef PERL_MAGIC_pos
# define PERL_MAGIC_pos '.'
#endif
#ifndef PERL_MAGIC_backref
# define PERL_MAGIC_backref '<'
#endif
#ifndef PERL_MAGIC_ext
# define PERL_MAGIC_ext '~'
#endif
/* That's the best we can do... */
#ifndef SvPV_force_nomg
# define SvPV_force_nomg SvPV_force
#endif
#ifndef SvPV_nomg
# define SvPV_nomg SvPV
#endif
#ifndef sv_catpvn_nomg
# define sv_catpvn_nomg sv_catpvn
#endif
#ifndef sv_catsv_nomg
# define sv_catsv_nomg sv_catsv
#endif
#ifndef sv_setsv_nomg
# define sv_setsv_nomg sv_setsv
#endif
#ifndef sv_pvn_nomg
# define sv_pvn_nomg sv_pvn
#endif
#ifndef SvIV_nomg
# define SvIV_nomg SvIV
#endif
#ifndef SvUV_nomg
# define SvUV_nomg SvUV
#endif
#ifndef sv_catpv_mg
# define sv_catpv_mg(sv, ptr) \
STMT_START { \
SV *TeMpSv = sv; \
sv_catpv(TeMpSv,ptr); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_catpvn_mg
# define sv_catpvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_catpvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_catsv_mg
# define sv_catsv_mg(dsv, ssv) \
STMT_START { \
SV *TeMpSv = dsv; \
sv_catsv(TeMpSv,ssv); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setiv_mg
# define sv_setiv_mg(sv, i) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setiv(TeMpSv,i); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setnv_mg
# define sv_setnv_mg(sv, num) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setnv(TeMpSv,num); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setpv_mg
# define sv_setpv_mg(sv, ptr) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setpv(TeMpSv,ptr); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setpvn_mg
# define sv_setpvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setpvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setsv_mg
# define sv_setsv_mg(dsv, ssv) \
STMT_START { \
SV *TeMpSv = dsv; \
sv_setsv(TeMpSv,ssv); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setuv_mg
# define sv_setuv_mg(sv, i) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setuv(TeMpSv,i); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_usepvn_mg
# define sv_usepvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_usepvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifdef USE_ITHREADS
#ifndef CopFILE
# define CopFILE(c) ((c)->cop_file)
#endif
#ifndef CopFILEGV
# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
#endif
#ifndef CopFILE_set
# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
#endif
#ifndef CopFILESV
# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
#endif
#ifndef CopFILEAV
# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
#endif
#ifndef CopSTASHPV
# define CopSTASHPV(c) ((c)->cop_stashpv)
#endif
#ifndef CopSTASHPV_set
# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
#endif
#ifndef CopSTASH
# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
#endif
#ifndef CopSTASH_set
# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
#endif
#ifndef CopSTASH_eq
# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
|| (CopSTASHPV(c) && HvNAME(hv) \
&& strEQ(CopSTASHPV(c), HvNAME(hv)))))
#endif
#else
#ifndef CopFILEGV
# define CopFILEGV(c) ((c)->cop_filegv)
#endif
#ifndef CopFILEGV_set
# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
#endif
#ifndef CopFILE_set
# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
#endif
#ifndef CopFILESV
# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
#endif
#ifndef CopFILEAV
# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
#endif
#ifndef CopFILE
# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
#endif
#ifndef CopSTASH
# define CopSTASH(c) ((c)->cop_stash)
#endif
#ifndef CopSTASH_set
# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
#endif
#ifndef CopSTASHPV
# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
#endif
#ifndef CopSTASHPV_set
# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
#endif
#ifndef CopSTASH_eq
# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
#endif
#endif /* USE_ITHREADS */
#ifndef IN_PERL_COMPILETIME
# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
#endif
#ifndef IN_LOCALE_RUNTIME
# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
#endif
#ifndef IN_LOCALE_COMPILETIME
# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
#endif
#ifndef IN_LOCALE
# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
#endif
#ifndef IS_NUMBER_IN_UV
# define IS_NUMBER_IN_UV 0x01
#endif
#ifndef IS_NUMBER_GREATER_THAN_UV_MAX
# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
#endif
#ifndef IS_NUMBER_NOT_INT
# define IS_NUMBER_NOT_INT 0x04
#endif
#ifndef IS_NUMBER_NEG
# define IS_NUMBER_NEG 0x08
#endif
#ifndef IS_NUMBER_INFINITY
# define IS_NUMBER_INFINITY 0x10
#endif
#ifndef IS_NUMBER_NAN
# define IS_NUMBER_NAN 0x20
#endif
/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
#ifndef GROK_NUMERIC_RADIX
# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
#endif
#ifndef PERL_SCAN_GREATER_THAN_UV_MAX
# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
#endif
#ifndef PERL_SCAN_SILENT_ILLDIGIT
# define PERL_SCAN_SILENT_ILLDIGIT 0x04
#endif
#ifndef PERL_SCAN_ALLOW_UNDERSCORES
# define PERL_SCAN_ALLOW_UNDERSCORES 0x01
#endif
#ifndef PERL_SCAN_DISALLOW_PREFIX
# define PERL_SCAN_DISALLOW_PREFIX 0x02
#endif
#ifndef grok_numeric_radix
#if defined(NEED_grok_numeric_radix)
static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
static
#else
extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
#endif
#ifdef grok_numeric_radix
# undef grok_numeric_radix
#endif
#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
bool
DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
{
#ifdef USE_LOCALE_NUMERIC
#ifdef PL_numeric_radix_sv
if (PL_numeric_radix_sv && IN_LOCALE) {
STRLEN len;
char* radix = SvPV(PL_numeric_radix_sv, len);
if (*sp + len <= send && memEQ(*sp, radix, len)) {
*sp += len;
return TRUE;
}
}
#else
/* older perls don't have PL_numeric_radix_sv so the radix
* must manually be requested from locale.h
*/
#include <locale.h>
dTHR; /* needed for older threaded perls */
struct lconv *lc = localeconv();
char *radix = lc->decimal_point;
if (radix && IN_LOCALE) {
STRLEN len = strlen(radix);
if (*sp + len <= send && memEQ(*sp, radix, len)) {
*sp += len;
return TRUE;
}
}
#endif /* PERL_VERSION */
#endif /* USE_LOCALE_NUMERIC */
/* always try "." if numeric radix didn't match because
* we may have data from different locales mixed */
if (*sp < send && **sp == '.') {
++*sp;
return TRUE;
}
return FALSE;
}
#endif
#endif
/* grok_number depends on grok_numeric_radix */
#ifndef grok_number
#if defined(NEED_grok_number)
static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
static
#else
extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
#endif
#ifdef grok_number
# undef grok_number
#endif
#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
#define Perl_grok_number DPPP_(my_grok_number)
#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
int
DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
{
const char *s = pv;
const char *send = pv + len;
const UV max_div_10 = UV_MAX / 10;
const char max_mod_10 = UV_MAX % 10;
int numtype = 0;
int sawinf = 0;
int sawnan = 0;
while (s < send && isSPACE(*s))
s++;
if (s == send) {
return 0;
} else if (*s == '-') {
s++;
numtype = IS_NUMBER_NEG;
}
else if (*s == '+')
s++;
if (s == send)
return 0;
/* next must be digit or the radix separator or beginning of infinity */
if (isDIGIT(*s)) {
/* UVs are at least 32 bits, so the first 9 decimal digits cannot
overflow. */
UV value = *s - '0';
/* This construction seems to be more optimiser friendly.
(without it gcc does the isDIGIT test and the *s - '0' separately)
With it gcc on arm is managing 6 instructions (6 cycles) per digit.
In theory the optimiser could deduce how far to unroll the loop
before checking for overflow. */
if (++s < send) {
int digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
/* Now got 9 digits, so need to check
each time for overflow. */
digit = *s - '0';
while (digit >= 0 && digit <= 9
&& (value < max_div_10
|| (value == max_div_10
&& digit <= max_mod_10))) {
value = value * 10 + digit;
if (++s < send)
digit = *s - '0';
else
break;
}
if (digit >= 0 && digit <= 9
&& (s < send)) {
/* value overflowed.
skip the remaining digits, don't
worry about setting *valuep. */
do {
s++;
} while (s < send && isDIGIT(*s));
numtype |=
IS_NUMBER_GREATER_THAN_UV_MAX;
goto skip_value;
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
numtype |= IS_NUMBER_IN_UV;
if (valuep)
*valuep = value;
skip_value:
if (GROK_NUMERIC_RADIX(&s, send)) {
numtype |= IS_NUMBER_NOT_INT;
while (s < send && isDIGIT(*s)) /* optional digits after the radix */
s++;
}
}
else if (GROK_NUMERIC_RADIX(&s, send)) {
numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
/* no digits before the radix means we need digits after it */
if (s < send && isDIGIT(*s)) {
do {
s++;
} while (s < send && isDIGIT(*s));
if (valuep) {
/* integer approximation is valid - it's 0. */
*valuep = 0;
}
}
else
return 0;
} else if (*s == 'I' || *s == 'i') {
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
s++; if (s < send && (*s == 'I' || *s == 'i')) {
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
s++;
}
sawinf = 1;
} else if (*s == 'N' || *s == 'n') {
/* XXX TODO: There are signaling NaNs and quiet NaNs. */
s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++;
sawnan = 1;
} else
return 0;
if (sawinf) {
numtype &= IS_NUMBER_NEG; /* Keep track of sign */
numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
} else if (sawnan) {
numtype &= IS_NUMBER_NEG; /* Keep track of sign */
numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
} else if (s < send) {
/* we can have an optional exponent part */
if (*s == 'e' || *s == 'E') {
/* The only flag we keep is sign. Blow away any "it's UV" */
numtype &= IS_NUMBER_NEG;
numtype |= IS_NUMBER_NOT_INT;
s++;
if (s < send && (*s == '-' || *s == '+'))
s++;
if (s < send && isDIGIT(*s)) {
do {
s++;
} while (s < send && isDIGIT(*s));
}
else
return 0;
}
}
while (s < send && isSPACE(*s))
s++;
if (s >= send)
return numtype;
if (len == 10 && memEQ(pv, "0 but true", 10)) {
if (valuep)
*valuep = 0;
return IS_NUMBER_IN_UV;
}
return 0;
}
#endif
#endif
/*
* The grok_* routines have been modified to use warn() instead of
* Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
* which is why the stack variable has been renamed to 'xdigit'.
*/
#ifndef grok_bin
#if defined(NEED_grok_bin)
static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
static
#else
extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
#endif
#ifdef grok_bin
# undef grok_bin
#endif
#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
#define Perl_grok_bin DPPP_(my_grok_bin)
#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
UV
DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_2 = UV_MAX / 2;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
/* strip off leading b or 0b.
for compatibility silently suffer "b" and "0b" as valid binary
numbers. */
if (len >= 1) {
if (s[0] == 'b') {
s++;
len--;
}
else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
s+=2;
len-=2;
}
}
}
for (; len-- && *s; s++) {
char bit = *s;
if (bit == '0' || bit == '1') {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
With gcc seems to be much straighter code than old scan_bin. */
redo:
if (!overflowed) {
if (value <= max_div_2) {
value = (value << 1) | (bit - '0');
continue;
}
/* Bah. We're just overflowed. */
warn("Integer overflow in binary number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 2.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount. */
value_nv += (NV)(bit - '0');
continue;
}
if (bit == '_' && len && allow_underscores && (bit = s[1])
&& (bit == '0' || bit == '1'))
{
--len;
++s;
goto redo;
}
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal binary digit '%c' ignored", *s);
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Binary number > 0b11111111111111111111111111111111 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_hex
#if defined(NEED_grok_hex)
static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
static
#else
extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
#endif
#ifdef grok_hex
# undef grok_hex
#endif
#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
#define Perl_grok_hex DPPP_(my_grok_hex)
#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
UV
DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_16 = UV_MAX / 16;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
const char *xdigit;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
/* strip off leading x or 0x.
for compatibility silently suffer "x" and "0x" as valid hex numbers.
*/
if (len >= 1) {
if (s[0] == 'x') {
s++;
len--;
}
else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
s+=2;
len-=2;
}
}
}
for (; len-- && *s; s++) {
xdigit = strchr((char *) PL_hexdigit, *s);
if (xdigit) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
With gcc seems to be much straighter code than old scan_hex. */
redo:
if (!overflowed) {
if (value <= max_div_16) {
value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
continue;
}
warn("Integer overflow in hexadecimal number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 16.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount of 16-tuples. */
value_nv += (NV)((xdigit - PL_hexdigit) & 15);
continue;
}
if (*s == '_' && len && allow_underscores && s[1]
&& (xdigit = strchr((char *) PL_hexdigit, s[1])))
{
--len;
++s;
goto redo;
}
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal hexadecimal digit '%c' ignored", *s);
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Hexadecimal number > 0xffffffff non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_oct
#if defined(NEED_grok_oct)
static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
static
#else
extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
#endif
#ifdef grok_oct
# undef grok_oct
#endif
#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
#define Perl_grok_oct DPPP_(my_grok_oct)
#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
UV
DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
out front allows slicker code. */
int digit = *s - '0';
if (digit >= 0 && digit <= 7) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
*/
redo:
if (!overflowed) {
if (value <= max_div_8) {
value = (value << 3) | digit;
continue;
}
/* Bah. We're just overflowed. */
warn("Integer overflow in octal number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 8.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount of 8-tuples. */
value_nv += (NV)digit;
continue;
}
if (digit == ('_' - '0') && len && allow_underscores
&& (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
{
--len;
++s;
goto redo;
}
/* Allow \octal to work the DWIM way (that is, stop scanning
* as soon as non-octal characters are seen, complain only iff
* someone seems to want to use the digits eight and nine). */
if (digit == 8 || digit == 9) {
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal octal digit '%c' ignored", *s);
}
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Octal number > 037777777777 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifdef NO_XSLOCKS
# ifdef dJMPENV
# define dXCPT dJMPENV; int rEtV = 0
# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
# define XCPT_TRY_END JMPENV_POP;
# define XCPT_CATCH if (rEtV != 0)
# define XCPT_RETHROW JMPENV_JUMP(rEtV)
# else
# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
# define XCPT_CATCH if (rEtV != 0)
# define XCPT_RETHROW Siglongjmp(top_env, rEtV)
# endif
#endif
#endif /* _P_P_PORTABILITY_H_ */
/* End of File ppport.h */
t/01-samples.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 10;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
###
NAME 'Create a Maximum Entropy Leaner';
my $me = AI::MaxEntropy->new;
ok $me,
$__;
###
NAME 'Add a sample';
$me->see(['round', 'red'] => 'tomato');
is_deeply
[
$me->{samples},
$me->{x_bucket},
$me->{y_bucket},
$me->{x_list},
$me->{y_list},
$me->{x_num},
$me->{y_num},
$me->{f_num},
$me->{af_num},
$me->{f_freq},
$me->{f_map},
$me->{last_cut}
],
[
[ [ [ 0, 1 ] => 0 => 1 ] ],
{ round => 0, red => 1 },
{ tomato => 0 },
[ 'round', 'red' ],
[ 'tomato' ],
2,
1,
0,
2,
[[1, 1]],
[],
-1
],
$__;
###
NAME 'Cut #1';
$me->cut(0);
is_deeply
[
$me->{f_num},
$me->{f_map},
$me->{last_cut}
],
[
2,
[ [0, 1] ],
0
],
$__;
###
NAME 'Add more samples';
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
is_deeply
[
$me->{samples},
$me->{x_bucket},
$me->{y_bucket},
$me->{x_list},
$me->{y_list},
$me->{x_num},
$me->{y_num},
$me->{af_num},
$me->{f_freq},
$me->{last_cut}
],
[
[
[ [ 0, 1 ] => 0 => 1 ],
[ [ 0, 2, 1 ] => 1 => 2 ],
[ [ 3, 2, 4 ] => 2 => 3 ]
],
{ round => 0, red => 1, smooth => 2, long => 3, yellow => 4 },
{ tomato => 0, apple => 1, banana => 2 },
[ 'round', 'red', 'smooth', 'long', 'yellow' ],
[ 'tomato', 'apple', 'banana' ],
5,
3,
-1,
[
[1, 1, 0, 0, 0],
[2, 2, 2, 0, 0],
[0, 0, 3, 3, 3]
],
-1
],
$__;
###
NAME 'Cut #2';
$me->cut(1);
is_deeply
[
$me->{f_num},
$me->{f_map},
$me->{last_cut}
],
[
8,
[
[0, 1, -1, -1, -1],
[2, 3, 4, -1, -1],
[-1, -1, 5, 6, 7]
],
1
],
$__;
###
NAME 'Forget samples';
$me->forget_all;
is_deeply
[
$me->{samples},
$me->{x_bucket},
$me->{y_bucket},
$me->{x_list},
$me->{y_list},
$me->{x_num},
$me->{y_num},
$me->{f_num},
$me->{af_num},
$me->{f_freq},
$me->{f_map},
$me->{last_cut}
],
[
[],
{},
{},
[],
[],
0,
0,
0,
0,
[],
[],
-1
],
$__;
###
NAME 'Add attribute-value samples';
$me->see({color => ['red', 'green'], shape => 'round'} => 'apple');
$me->see({surface => 'smooth', color => 'red'} => 'tomato');
is_deeply
[
$me->{samples},
$me->{x_bucket},
$me->{y_bucket},
$me->{x_list},
$me->{y_list},
$me->{x_num},
$me->{y_num},
$me->{f_num},
$me->{af_num},
$me->{f_freq},
$me->{f_map},
$me->{last_cut}
],
[
[
[ [ 0, 1, 2 ] => 0 => 1 ],
[ [ 3, 0 ] => 1 => 1 ]
],
{ 'color:red' => 0, 'color:green' => 1,
'shape:round' => 2, 'surface:smooth' => 3 },
{ 'apple' => 0, 'tomato' => 1 },
[ 'color:red', 'color:green', 'shape:round', 'surface:smooth' ],
[ 'apple', 'tomato' ],
4,
2,
0,
-1,
[
[1, 1, 1, 0],
[1, 0, 0, 1]
],
[],
-1
],
$__;
###
NAME 'Yet another test on af_num and f_freq';
$me->forget_all;
$me->see(['a', 'b'] => 'x');
$me->see(['c', 'd'] => 'x');
$me->see(['a', 'c'] => 'y');
$me->see(['a', 'd'] => 'x');
is_deeply
[
$me->{af_num},
$me->{f_freq},
$me->{f_map},
$me->{f_num},
$me->{last_cut}
],
[
2,
[
[2, 1, 1, 2],
[1, 0, 1, 0]
],
[],
0,
-1
],
$__;
###
NAME 'Cut #3';
$me->cut(2);
is_deeply
[
$me->{f_num},
$me->{f_map},
$me->{last_cut}
],
[
2,
[
[0, -1, -1, 1],
[-1, -1, -1, -1]
],
2
],
$__;
t/02-learn_by_lbfgs.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 5;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
my $me = AI::MaxEntropy->new(smoother => {});
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
$me->cut(0);
$me->_cache;
###
NAME 'Negative log likelihood calculation (lambda = all 0)';
my ($f, $g) = AI::MaxEntropy::_neg_log_likelihood(
[0, 0, 0, 0, 0, 0, 0, 0, 0, 0], undef, $me
);
delta_ok
[
$f,
$g
],
[
- (2 * log(0.5) + 3 * log(0.5)),
[
- ((1 - 0.5) * 2 + 0 * 3),
- ((1 - 0.5) * 2 + (0 - 0.5) * 3),
- ((1 - 0.5) * 2 + 0 * 3),
- (0 * 2 + (0 - 0.5) * 3),
- (0 * 2 + (0 - 0.5) * 3),
- ((0 - 0.5) * 2 + 0 * 3),
- ((0 - 0.5) * 2 + (1 -0.5) * 3),
- ((0 - 0.5) * 2 + 0 * 3),
- (0 * 2 + (1 - 0.5) * 3),
- (0 * 2 + (1 - 0.5) * 3)
]
],
$__;
###
NAME 'Negative log likelihood calculation (lambda = random .1 and 0)';
($f, $g) = AI::MaxEntropy::_neg_log_likelihood(
[.1, .1, 0, 0, 0, .1, .1, 0, 0, .1], undef, $me
);
delta_ok
[
$f,
$g
],
[
- (log(exp(.1) / (2 * exp(.1))) * 2 +
log(exp(.2) / (exp(.1) + exp(.2))) * 3),
[
- ((1 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3),
- ((1 - exp(.1) / (2 * exp(.1))) * 2 +
(0 - exp(.1) / (exp(.1) + exp(.2))) * 3),
- ((1 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3),
- (0 * 2 + (0 - exp(.1) / (exp(.1) + exp(.2))) * 3),
- (0 * 2 + (0 - exp(.1) / (exp(.1) + exp(.2))) * 3),
- ((0 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3),
- ((0 - exp(.1) / (2 * exp(.1))) * 2 +
(1 - exp(.2) / (exp(.1) + exp(.2))) * 3),
- ((0 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3),
- (0 * 2 + (1 - exp(.2) / (exp(.1) + exp(.2))) * 3),
- (0 * 2 + (1 - exp(.2) / (exp(.1) + exp(.2))) * 3)
]
],
$__;
###
NAME 'Negative log likelihood calculation (with Gaussian smoother)';
$me->{smoother} = { type => 'gaussian', sigma => .5 };
($f, $g) = AI::MaxEntropy::_neg_log_likelihood(
[0, 0, .1, .1, 0, 0, 0, .1, .1, .1], undef, $me
);
delta_ok
[
$f,
$g
],
[
- (log(exp(.1) / (2 * exp(.1))) * 2 +
log(exp(.2) / (exp(.1) + exp(.2))) * 3 -
(5 * .1 ** 2) / (2 * .5 ** 2)),
[
- ((1 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3 - 0 / .5 ** 2),
- ((1 - exp(.1) / (2 * exp(.1))) * 2 +
(0 - exp(.1) / (exp(.1) + exp(.2))) * 3 - 0 / .5 ** 2),
- ((1 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3 - .1 / .5 ** 2),
- (0 * 2 + (0 - exp(.1) / (exp(.1) + exp(.2))) * 3 - .1 / .5 ** 2),
- (0 * 2 + (0 - exp(.1) / (exp(.1) + exp(.2))) * 3 - 0 / .5 ** 2),
- ((0 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3 - 0 / .5 ** 2),
- ((0 - exp(.1) / (2 * exp(.1))) * 2 +
(1 - exp(.2) / (exp(.1) + exp(.2))) * 3 - 0 / .5 ** 2),
- ((0 - exp(.1) / (2 * exp(.1))) * 2 + 0 * 3 - .1 / .5 ** 2),
- (0 * 2 + (1 - exp(.2) / (exp(.1) + exp(.2))) * 3 - .1 / .5 ** 2),
- (0 * 2 + (1 - exp(.2) / (exp(.1) + exp(.2))) * 3 - .1 / .5 ** 2)
]
],
$__;
$me->_free_cache;
###
NAME 'Model object construction';
$me->{smoother} = {};
my $model = $me->learn;
is_deeply
[
$model->{x_bucket},
$model->{y_bucket},
$model->{x_list},
$model->{y_list},
$model->{x_num},
$model->{y_num},
$model->{f_num},
$model->{f_map}
],
[
{ round => 0, smooth => 1, red => 2, long => 3, yellow => 4 },
{ apple => 0, banana => 1 },
[ 'round', 'smooth', 'red', 'long', 'yellow' ],
[ 'apple', 'banana' ],
5,
2,
10,
[
[0, 1, 2, 3, 4],
[5, 6, 7, 8, 9]
]
],
$__;
t/03-learn_by_gis.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 3;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
my ($lambda, $d_lambda, $p1_f, $n);
my $zero = 1e-5;
my $me = AI::MaxEntropy->new();
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
$me->{algorithm}->{type} = 'gis';
###
NAME 'The first iteration';
$me->{algorithm}->{progress_cb} =
sub { ($lambda, $d_lambda) = ($_[1], $_[2]); 1 };
$me->learn;
$p1_f = [
2 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))) + 3 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))),
3 * (exp(0) / (exp(0) + exp(0))),
3 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))) + 3 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))),
3 * (exp(0) / (exp(0) + exp(0))),
3 * (exp(0) / (exp(0) + exp(0)))
];
delta_ok
[
$lambda,
$d_lambda
],
[
[
(1.0 / 3) * log(2 / $p1_f->[0]),
(1.0 / 3) * log(2 / $p1_f->[1]),
(1.0 / 3) * log(2 / $p1_f->[2]),
(1.0 / 3) * log($zero / $p1_f->[3]),
(1.0 / 3) * log($zero / $p1_f->[4]),
(1.0 / 3) * log($zero / $p1_f->[5]),
(1.0 / 3) * log(3 / $p1_f->[6]),
(1.0 / 3) * log($zero / $p1_f->[7]),
(1.0 / 3) * log(3 / $p1_f->[8]),
(1.0 / 3) * log(3 / $p1_f->[9])
],
[
(1.0 / 3) * log(2 / $p1_f->[0]),
(1.0 / 3) * log(2 / $p1_f->[1]),
(1.0 / 3) * log(2 / $p1_f->[2]),
(1.0 / 3) * log($zero / $p1_f->[3]),
(1.0 / 3) * log($zero / $p1_f->[4]),
(1.0 / 3) * log($zero / $p1_f->[5]),
(1.0 / 3) * log(3 / $p1_f->[6]),
(1.0 / 3) * log($zero / $p1_f->[7]),
(1.0 / 3) * log(3 / $p1_f->[8]),
(1.0 / 3) * log(3 / $p1_f->[9])
]
],
$__;
###
NAME 'The second iteration';
my @l = @$lambda;
$me->{algorithm}->{progress_cb} =
sub { ($lambda, $d_lambda) = ($_[1], $_[2]); $n++; $n >= 2 ? 1 : 0 };
$me->learn;
my $p0 = exp($l[0] + $l[1] + $l[2]) + exp($l[5] + $l[6] + $l[7]);
my $p0_0 = exp($l[0] + $l[1] + $l[2]) / $p0;
my $p0_1 = exp($l[5] + $l[6] + $l[7]) / $p0;
my $p1 = exp($l[6] + $l[8] + $l[9]) + exp($l[1] + $l[3] + $l[4]);
my $p1_0 = exp($l[1] + $l[3] + $l[4]) / $p1;
my $p1_1 = exp($l[6] + $l[8] + $l[9]) / $p1;
$p1_f = [
2 * $p0_0,
2 * $p0_0 + 3 * $p1_0,
2 * $p0_0,
3 * $p1_0,
3 * $p1_0,
2 * $p0_1,
2 * $p0_1 + 3 * $p1_1,
2 * $p0_1,
3 * $p1_1,
3 * $p1_1
];
delta_ok
[
$lambda,
$d_lambda
],
[
[
$l[0] + (1.0 / 3) * log(2 / $p1_f->[0]),
$l[1] + (1.0 / 3) * log(2 / $p1_f->[1]),
$l[2] + (1.0 / 3) * log(2 / $p1_f->[2]),
$l[3] + (1.0 / 3) * log($zero / $p1_f->[3]),
$l[4] + (1.0 / 3) * log($zero / $p1_f->[4]),
$l[5] + (1.0 / 3) * log($zero / $p1_f->[5]),
$l[6] + (1.0 / 3) * log(3 / $p1_f->[6]),
$l[7] + (1.0 / 3) * log($zero / $p1_f->[7]),
$l[8] + (1.0 / 3) * log(3 / $p1_f->[8]),
$l[9] + (1.0 / 3) * log(3 / $p1_f->[9])
],
[
(1.0 / 3) * log(2 / $p1_f->[0]),
(1.0 / 3) * log(2 / $p1_f->[1]),
(1.0 / 3) * log(2 / $p1_f->[2]),
(1.0 / 3) * log($zero / $p1_f->[3]),
(1.0 / 3) * log($zero / $p1_f->[4]),
(1.0 / 3) * log($zero / $p1_f->[5]),
(1.0 / 3) * log(3 / $p1_f->[6]),
(1.0 / 3) * log($zero / $p1_f->[7]),
(1.0 / 3) * log(3 / $p1_f->[8]),
(1.0 / 3) * log(3 / $p1_f->[9])
]
],
$__;
t/04-model.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 5;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load AI::MaxEntropy';
BEGIN { use_ok 'AI::MaxEntropy' }
###
NAME 'Load AI::MaxEntropy::Model';
BEGIN { use_ok 'AI::MaxEntropy::Model' }
my $me = AI::MaxEntropy->new;
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
###
NAME 'Predict with model - LBFGS';
my $model = $me->learn;
is_deeply
[
$model->predict(['round']),
$model->predict(['red']),
$model->predict(['long']),
$model->predict(['yellow']),
$model->predict(['smooth']),
$model->predict(['round', 'smooth']),
$model->predict(['red', 'long']),
$model->predict(['red', 'yellow']),
],
[
'apple',
'apple',
'banana',
'banana',
'banana',
'apple',
'banana',
'banana'
],
$__;
###
NAME 'Predict with model - GIS';
$me->{algorithm}->{type} = 'gis';
$model = $me->learn;
is_deeply
[
$model->predict(['round']),
$model->predict(['red']),
$model->predict(['long']),
$model->predict(['yellow']),
$model->predict(['smooth']),
$model->predict(['round', 'smooth']),
$model->predict(['red', 'long']),
$model->predict(['red', 'yellow']),
],
[
'apple',
'apple',
'banana',
'banana',
'banana',
'apple',
'banana',
'banana'
],
$__;
###
NAME 'Model writing and loading';
$model->save('test_model');
my $model1 = AI::MaxEntropy::Model->new('test_model');
unlink 'test_model';
is_deeply $model, $model1,
$__;
t/05-util.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 8;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy::Util', qw(:all) }
###
NAME 'traverse_partially x-x-x';
my $a = [1, 2, 3, 4, 5];
my $b = [];
traverse_partially { push @$b, $_ } $a, 'x-x-x';
is_deeply $b, [1, 3, 5],
$__;
###
NAME 'traverse_partially o-o-o => o';
$a = [1, 2, 3, 4, 5, 6];
$b = [];
traverse_partially { push @$b, $_ } $a, 'o-o-o' => 'o';
is_deeply $b, [1, 3, 5, 6],
$__;
###
NAME 'map_partially o-o => o';
$a = [1, 2, 3, 4, 5, 6];
$b = map_partially { $_ + 1 } $a, 'o-o' => 'o';
is_deeply $b, [2, 3, 6, 7],
$__;
###
NAME 'train_and_test xxo';
require AI::MaxEntropy;
my ($me, $samples, $result, $model);
$me = AI::MaxEntropy->new;
$samples = [
[['a', 'b', 'c'] => 'x'],
[['e', 'f'] => 'z'],
[['e'] => 'z']
];
($result, $model) = train_and_test($me, $samples, 'xxo');
is_deeply
$result,
[
[[['e'] => 'z'] => 'z']
],
$__;
###
NAME 'train_and_test xxxxo';
$me->forget_all;
$samples = [
[['a', 'b'] => 'x'],
[['c', 'd'] => 'y'],
[['i', 'j'] => 'z'],
[['p', 'q'] => 'xx'],
[['a'] => 'x'],
[['c'] => 'x' => 2]
];
($result, $model) = train_and_test($me, $samples, 'xxxxo');
is_deeply
$result,
[
[[['a'] => 'x'] => 'x'],
[[['c'] => 'x' => 2] => 'y']
],
$__;
###
NAME 'precision';
delta_ok precision($result), 1 / 3,
$__;
###
NAME 'recall of x';
delta_ok recall($result, 'x'), 1 / 3,
$__;
use strict;
use warnings;
use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
all_pod_files_ok();
view release on metacpan - search on metacpan
( run in 2.113 seconds using v1.00-cache-2.02-grep-82fe00e-cpan-cec75d87357c )