lib/Term/ANSIColor/README Term::ANSIColor
lib/Term/ANSIColor/test.pl See if Term::ANSIColor works
lib/Term/Cap.pm Perl module supporting termcap usage
+lib/Term/Cap.t See if Term::Cap works
lib/Term/Complete.pm A command completion subroutine
lib/Term/Complete.t See if Term::Complete works
lib/Term/ReadLine.pm Stub readline library
lib/Text/Soundex.pm Perl module to implement Soundex
lib/Text/Soundex.t See if Soundex works
lib/Text/Tabs.pm Do expand and unexpand
+lib/Text/TabsWrap/CHANGELOG ChangeLog for Tabs+Wrap
lib/Text/TabsWrap/t/fill.t See if Text::Wrap::fill works
lib/Text/TabsWrap/t/tabs.t See if Text::Tabs works
lib/Text/TabsWrap/t/wrap.t See if Text::Wrap::wrap works
#define mess Perl_mess
#define vmess Perl_vmess
#define qerror Perl_qerror
+#define sortsv Perl_sortsv
#define mg_clear Perl_mg_clear
#define mg_copy Perl_mg_copy
#define mg_find Perl_mg_find
#define sv_2iv Perl_sv_2iv
#define sv_2mortal Perl_sv_2mortal
#define sv_2nv Perl_sv_2nv
-#ifdef CRIPPLED_CC
#define sv_2pv Perl_sv_2pv
-#endif
#define sv_2pvutf8 Perl_sv_2pvutf8
#define sv_2pvbyte Perl_sv_2pvbyte
-#ifdef CRIPPLED_CC
#define sv_pvn_nomg Perl_sv_pvn_nomg
-#endif
#define sv_2uv Perl_sv_2uv
#define sv_iv Perl_sv_iv
#define sv_uv Perl_sv_uv
#define sv_catpvf Perl_sv_catpvf
#define sv_vcatpvf Perl_sv_vcatpvf
#define sv_catpv Perl_sv_catpv
-#ifdef CRIPPLED_CC
#define sv_catpvn Perl_sv_catpvn
-#endif
-#ifdef CRIPPLED_CC
#define sv_catsv Perl_sv_catsv
-#endif
#define sv_chop Perl_sv_chop
#define sv_clean_all Perl_sv_clean_all
#define sv_clean_objs Perl_sv_clean_objs
#define sv_peek Perl_sv_peek
#define sv_pos_u2b Perl_sv_pos_u2b
#define sv_pos_b2u Perl_sv_pos_b2u
-#ifdef CRIPPLED_CC
#define sv_pvn_force Perl_sv_pvn_force
-#endif
#define sv_pvutf8n_force Perl_sv_pvutf8n_force
#define sv_pvbyten_force Perl_sv_pvbyten_force
#define sv_reftype Perl_sv_reftype
#define sv_setref_pvn Perl_sv_setref_pvn
#define sv_setpv Perl_sv_setpv
#define sv_setpvn Perl_sv_setpvn
-#ifdef CRIPPLED_CC
#define sv_setsv Perl_sv_setsv
-#endif
#define sv_taint Perl_sv_taint
#define sv_tainted Perl_sv_tainted
#define sv_unmagic Perl_sv_unmagic
#define sv_pv Perl_sv_pv
#define sv_pvutf8 Perl_sv_pvutf8
#define sv_pvbyte Perl_sv_pvbyte
-#ifdef CRIPPLED_CC
#define sv_utf8_upgrade Perl_sv_utf8_upgrade
-#endif
#define sv_utf8_downgrade Perl_sv_utf8_downgrade
#define sv_utf8_encode Perl_sv_utf8_encode
#define sv_utf8_decode Perl_sv_utf8_decode
#define save_lines S_save_lines
#define doeval S_doeval
#define doopen_pmc S_doopen_pmc
-#define qsortsv S_qsortsv
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
#define do_maybe_phash S_do_maybe_phash
#endif
#define vmess(a,b) Perl_vmess(aTHX_ a,b)
#define qerror(a) Perl_qerror(aTHX_ a)
+#define sortsv(a,b,c) Perl_sortsv(aTHX_ a,b,c)
#define mg_clear(a) Perl_mg_clear(aTHX_ a)
#define mg_copy(a,b,c,d) Perl_mg_copy(aTHX_ a,b,c,d)
#define mg_find(a,b) Perl_mg_find(aTHX_ a,b)
#define save_lines(a,b) S_save_lines(aTHX_ a,b)
#define doeval(a,b) S_doeval(aTHX_ a,b)
#define doopen_pmc(a,b) S_doopen_pmc(aTHX_ a,b)
-#define qsortsv(a,b,c) S_qsortsv(aTHX_ a,b,c)
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
#define do_maybe_phash(a,b,c,d,e) S_do_maybe_phash(aTHX_ a,b,c,d,e)
else {
my ($flags,$retval,$func,@args) = @_;
unless ($flags =~ /o/) {
- $ret .= "#ifdef CRIPPLED_CC\n" if $flags =~ /C/;
if ($flags =~ /s/) {
$ret .= hide($func,"S_$func");
}
elsif ($flags =~ /p/) {
$ret .= hide($func,"Perl_$func");
}
- $ret .= "#endif\n" if $flags =~ /C/;
}
}
$ret;
:
: flags are single letters with following meanings:
: A member of public API
-: C wrap compatibility macro in #ifdef DCRIPPLED_CC
: d function has documentation with its source
: s static function, should have an S_ prefix in source
: file
Afp |SV* |mess |const char* pat|...
Ap |SV* |vmess |const char* pat|va_list* args
p |void |qerror |SV* err
+Apd |void |sortsv |SV ** array|size_t num_elts|SVCOMPARE_t f
Apd |int |mg_clear |SV* sv
Apd |int |mg_copy |SV* sv|SV* nsv|const char* key|I32 klen
Apd |MAGIC* |mg_find |SV* sv|int type
Apd |IV |sv_2iv |SV* sv
Apd |SV* |sv_2mortal |SV* sv
Apd |NV |sv_2nv |SV* sv
-ACp |char* |sv_2pv |SV* sv|STRLEN* lp
+Ap |char* |sv_2pv |SV* sv|STRLEN* lp
Apd |char* |sv_2pvutf8 |SV* sv|STRLEN* lp
Apd |char* |sv_2pvbyte |SV* sv|STRLEN* lp
-ACp |char* |sv_pvn_nomg |SV* sv|STRLEN* lp
+Ap |char* |sv_pvn_nomg |SV* sv|STRLEN* lp
Apd |UV |sv_2uv |SV* sv
Apd |IV |sv_iv |SV* sv
Apd |UV |sv_uv |SV* sv
Afpd |void |sv_catpvf |SV* sv|const char* pat|...
Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args
Apd |void |sv_catpv |SV* sv|const char* ptr
-ACpd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len
-ACpd |void |sv_catsv |SV* dsv|SV* ssv
+Apd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len
+Apd |void |sv_catsv |SV* dsv|SV* ssv
Apd |void |sv_chop |SV* sv|char* ptr
pd |I32 |sv_clean_all
pd |void |sv_clean_objs
Ap |char* |sv_peek |SV* sv
Apd |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp
Apd |void |sv_pos_b2u |SV* sv|I32* offsetp
-ACpd |char* |sv_pvn_force |SV* sv|STRLEN* lp
+Apd |char* |sv_pvn_force |SV* sv|STRLEN* lp
Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp
Apd |char* |sv_pvbyten_force|SV* sv|STRLEN* lp
Apd |char* |sv_reftype |SV* sv|int ob
|STRLEN n
Apd |void |sv_setpv |SV* sv|const char* ptr
Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len
-ACpd |void |sv_setsv |SV* dsv|SV* ssv
+Apd |void |sv_setsv |SV* dsv|SV* ssv
Apd |void |sv_taint |SV* sv
Apd |bool |sv_tainted |SV* sv
Apd |int |sv_unmagic |SV* sv|int type
Apd |char* |sv_pv |SV *sv
Apd |char* |sv_pvutf8 |SV *sv
Apd |char* |sv_pvbyte |SV *sv
-ACpd |STRLEN |sv_utf8_upgrade|SV *sv
+Apd |STRLEN |sv_utf8_upgrade|SV *sv
ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok
Apd |void |sv_utf8_encode |SV *sv
ApdM |bool |sv_utf8_decode |SV *sv
s |void |save_lines |AV *array|SV *sv
s |OP* |doeval |int gimme|OP** startop
s |PerlIO *|doopen_pmc |const char *name|const char *mode
-s |void |qsortsv |SV ** array|size_t num_elts|SVCOMPARE_t f
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
";
}
}
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
}
$Bless = "bless" unless defined $Bless;
#$Expdepth = 0 unless defined $Expdepth;
$Maxdepth = 0 unless defined $Maxdepth;
+$Useperl = 0 unless defined $Useperl;
+$Sortkeys = 0 unless defined $Sortkeys;
#
# expects an arrayref of values to be dumped.
'bless' => $Bless, # keyword to use for "bless"
# expdepth => $Expdepth, # cutoff depth for explicit dumping
maxdepth => $Maxdepth, # depth beyond which we give up
+ useperl => $Useperl, # use the pure Perl implementation
+ sortkeys => $Sortkeys, # flag or filter for sorting hash keys
};
if ($Indent > 0) {
sub Dump {
return &Dumpxs
- unless $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq});
+ unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) ||
+ $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq});
return &Dumpperl;
}
#
# twist, toil and turn;
# and recurse, of course.
+# sometimes sordidly;
+# and curse if no recourse.
#
sub _dump {
my($s, $val, $name) = @_;
($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
($mname = $name . '->');
$mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
- while (($k, $v) = each %$val) {
+ my ($sortkeys, $keys, $key) = ("$s->{sortkeys}");
+ if ($sortkeys) {
+ if (ref($s->{sortkeys}) eq 'CODE') {
+ $keys = $s->{sortkeys}($val);
+ unless (ref($keys) eq 'ARRAY') {
+ carp "Sortkeys subroutine did not return ARRAYREF";
+ $keys = [];
+ }
+ }
+ else {
+ $keys = [ sort keys %$val ];
+ }
+ }
+ while (($k, $v) = ! $sortkeys ? (each %$val) :
+ @$keys ? ($key = shift(@$keys), $val->{$key}) :
+ () )
+ {
my $nk = $s->_dump($k, "");
$nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
$sname = $mname . '{' . $nk . '}';
defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
}
+sub Useperl {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
+}
+
+sub Sortkeys {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'};
+}
+
# used by qquote below
my %esc = (
want to see more than enough). Default is 0, which means there is
no maximum depth.
+=item $Data::Dumper::Useperl I<or> $I<OBJ>->Useperl(I<[NEWVAL]>)
+
+Can be set to a boolean value which controls whether the pure Perl
+implementation of C<Data::Dumper> is used. The C<Data::Dumper> module is
+a dual implementation, with almost all functionality written in both
+pure Perl and also in XS ('C'). Since the XS version is much faster, it
+will always be used if possible. This option lets you override the
+default behavior, usually for testing purposes only. Default is 0, which
+means the XS implementation will be used if possible.
+
+=item $Data::Dumper::Sortkeys I<or> $I<OBJ>->Sortkeys(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether hash keys are dumped in
+sorted order. A true value will cause the keys of all hashes to be
+dumped in Perl's default sort order. Can also be set to a subroutine
+reference which will be called for each hash that is dumped. In this
+case C<Data::Dumper> will call the subroutine once for each hash,
+passing it the reference of the hash. The purpose of the subroutine is
+to return a reference to an array of the keys that will be dumped, in
+the order that they should be dumped. Using this feature, you can
+control both the order of the keys, and which keys are actually used. In
+other words, this subroutine acts as a filter by which you can exclude
+certain keys from being dumped. Default is 0, which means that hash keys
+are not sorted.
+
=back
=head2 Exports
print $d->Dump;
+ ########
+ # sorting and filtering hash keys
+ ########
+
+ $Data::Dumper::Sortkeys = \&my_filter;
+ my $foo = { map { (ord, "$_$_$_") } 'I'..'Q' };
+ my $bar = { %$foo };
+ my $baz = { reverse %$foo };
+ print Dumper [ $foo, $bar, $baz ];
+
+ sub my_filter {
+ my ($hash) = @_;
+ # return an array ref containing the hash keys to dump
+ # in the order that you want them to be dumped
+ return [
+ # Sort the keys of %$foo in reverse numeric order
+ $hash eq $foo ? (sort {$b <=> $a} keys %$hash) :
+ # Only dump the odd number keys of %$bar
+ $hash eq $bar ? (grep {$_ % 2} keys %$hash) :
+ # Sort keys in default order for all other hashes
+ (sort keys %$hash)
+ ];
+ }
+
=head1 BUGS
Due to limitations of Perl subroutine call semantics, you cannot pass an
SV *pad, SV *xpad, SV *apad, SV *sep,
SV *freezer, SV *toaster,
I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
- I32 maxdepth);
+ I32 maxdepth, SV *sortkeys);
/* does a string need to be protected? */
static I32
DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
- I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth)
+ I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
{
char tmpbuf[128];
U32 i;
DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth);
+ maxdepth, sortkeys);
sv_catpvn(retval, ")}", 2);
} /* plain */
else {
DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth);
+ maxdepth, sortkeys);
}
SvREFCNT_dec(namesv);
}
DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth);
+ maxdepth, sortkeys);
SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVAV) {
DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth);
+ maxdepth, sortkeys);
if (ix < ixmax)
sv_catpvn(retval, ",", 1);
}
char *key;
I32 klen;
SV *hval;
+ AV *keys = Nullav;
iname = newSVpvn(name, namelen);
if (name[0] == '%') {
sv_catsv(totpad, pad);
sv_catsv(totpad, apad);
- (void)hv_iterinit((HV*)ival);
+ /* If requested, get a sorted/filtered array of hash keys */
+ if (sortkeys) {
+ if (sortkeys == &PL_sv_yes) {
+ keys = newAV();
+ (void)hv_iterinit((HV*)ival);
+ while (entry = hv_iternext((HV*)ival)) {
+ sv = hv_iterkeysv(entry);
+ SvREFCNT_inc(sv);
+ av_push(keys, sv);
+ }
+ sortsv(AvARRAY(keys),
+ av_len(keys)+1,
+ Perl_sv_cmp_locale);
+ }
+ else {
+ dSP; ENTER; SAVETMPS; PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
+ i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
+ SPAGAIN;
+ if (i) {
+ sv = POPs;
+ if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
+ keys = (AV*)SvREFCNT_inc(SvRV(sv));
+ }
+ if (! keys)
+ warn("Sortkeys subroutine did not return ARRAYREF\n");
+ PUTBACK; FREETMPS; LEAVE;
+ }
+ if (keys)
+ sv_2mortal((SV*)keys);
+ }
+ else
+ (void)hv_iterinit((HV*)ival);
i = 0;
- while ((entry = hv_iternext((HV*)ival))) {
+ while (sortkeys ? (void*)(keys && (i <= av_len(keys))) :
+ (void*)((entry = hv_iternext((HV*)ival))) ) {
char *nkey = NULL;
I32 nticks = 0;
SV* keysv;
if (i)
sv_catpvn(retval, ",", 1);
+
+ if (sortkeys) {
+ char *key;
+ svp = av_fetch(keys, i, FALSE);
+ keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
+ key = SvPV(keysv, keylen);
+ svp = hv_fetch((HV*)ival, key, keylen, 0);
+ hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
+ }
+ else {
+ keysv = hv_iterkeysv(entry);
+ hval = hv_iterval((HV*)ival, entry);
+ }
+
i++;
- keysv = hv_iterkeysv(entry);
- hval = hv_iterval((HV*)ival, entry);
do_utf8 = DO_UTF8(keysv);
key = SvPV(keysv, keylen);
DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
postav, levelp, indent, pad, xpad, newapad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth);
+ maxdepth, sortkeys);
SvREFCNT_dec(sname);
Safefree(nkey);
if (indent >= 2)
DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
seenhv, postav, &nlevel, indent, pad, xpad,
newapad, sep, freezer, toaster, purity,
- deepcopy, quotekeys, bless, maxdepth);
+ deepcopy, quotekeys, bless, maxdepth,
+ sortkeys);
SvREFCNT_dec(e);
}
}
I32 indent, terse, i, imax, postlen;
SV **svp;
SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
- SV *freezer, *toaster, *bless;
+ SV *freezer, *toaster, *bless, *sortkeys;
I32 purity, deepcopy, quotekeys, maxdepth = 0;
char tmpbuf[1024];
I32 gimme = GIMME;
bless = *svp;
if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
maxdepth = SvIV(*svp);
+ if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
+ sortkeys = *svp;
+ if (! SvTRUE(sortkeys))
+ sortkeys = NULL;
+ else if (! (SvROK(sortkeys) &&
+ SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
+ {
+ /* flag to use qsortsv() for sorting hash keys */
+ sortkeys = &PL_sv_yes;
+ }
+ }
postav = newAV();
if (todumpav)
DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
postav, &level, indent, pad, xpad, newapad, sep,
freezer, toaster, purity, deepcopy, quotekeys,
- bless, maxdepth);
+ bless, maxdepth, sortkeys);
if (indent >= 2)
SvREFCNT_dec(newapad);
if (defined &Data::Dumper::Dumpxs) {
print "### XS extension loaded, will run XS tests\n";
- $TMAX = 192; $XS = 1;
+ $TMAX = 210; $XS = 1;
}
else {
print "### XS extensions not loaded, will NOT run XS tests\n";
- $TMAX = 96; $XS = 0;
+ $TMAX = 105; $XS = 0;
}
print "1..$TMAX\n";
TEST q(Data::Dumper->Dumpxs([$a], ['a']));
}
+
+{
+ $i = 0;
+ $a = { map { ("$_$_$_", ++$i) } 'I'..'Q' };
+ local $Data::Dumper::Sortkeys = 1;
+
+############# 193
+##
+ $WANT = <<'EOT';
+#$VAR1 = {
+# III => 1,
+# JJJ => 2,
+# KKK => 3,
+# LLL => 4,
+# MMM => 5,
+# NNN => 6,
+# OOO => 7,
+# PPP => 8,
+# QQQ => 9
+#};
+EOT
+
+TEST q(Data::Dumper->new([$a])->Dump;);
+TEST q(Data::Dumper->new([$a])->Dumpxs;)
+ if $XS;
+}
+
+{
+ $i = 5;
+ $c = { map { (++$i, "$_$_$_") } 'I'..'Q' };
+ local $Data::Dumper::Sortkeys = \&sort199;
+ sub sort199 {
+ my $hash = shift;
+ return [ sort { $b <=> $a } keys %$hash ];
+ }
+
+############# 199
+##
+ $WANT = <<'EOT';
+#$VAR1 = {
+# '14' => 'QQQ',
+# '13' => 'PPP',
+# '12' => 'OOO',
+# '11' => 'NNN',
+# '10' => 'MMM',
+# '9' => 'LLL',
+# '8' => 'KKK',
+# '7' => 'JJJ',
+# '6' => 'III'
+#};
+EOT
+
+TEST q(Data::Dumper->new([$c])->Dump;);
+TEST q(Data::Dumper->new([$c])->Dumpxs;)
+ if $XS;
+}
+
+{
+ $i = 5;
+ $c = { map { (++$i, "$_$_$_") } 'I'..'Q' };
+ $d = { reverse %$c };
+ local $Data::Dumper::Sortkeys = \&sort205;
+ sub sort205 {
+ my $hash = shift;
+ return [
+ $hash eq $c ? (sort { $a <=> $b } keys %$hash)
+ : (reverse sort keys %$hash)
+ ];
+ }
+
+############# 205
+##
+ $WANT = <<'EOT';
+#$VAR1 = [
+# {
+# '6' => 'III',
+# '7' => 'JJJ',
+# '8' => 'KKK',
+# '9' => 'LLL',
+# '10' => 'MMM',
+# '11' => 'NNN',
+# '12' => 'OOO',
+# '13' => 'PPP',
+# '14' => 'QQQ'
+# },
+# {
+# QQQ => '14',
+# PPP => '13',
+# OOO => '12',
+# NNN => '11',
+# MMM => '10',
+# LLL => '9',
+# KKK => '8',
+# JJJ => '7',
+# III => '6'
+# }
+#];
+EOT
+
+TEST q(Data::Dumper->new([[$c, $d]])->Dump;);
+TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;)
+ if $XS;
+}
($constname = $AUTOLOAD) =~ s/.*:://;
my ($error, $val) = constant($constname);
Carp::croak $error if $error;
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
}
XSLoader::load 'GDBM_File', $VERSION;
Perl_markstack_grow
Perl_mess
Perl_vmess
+Perl_sortsv
Perl_mg_clear
Perl_mg_copy
Perl_mg_find
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+END {
+ # let VMS whack all versions
+ 1 while unlink('tcout');
+}
+
+use Test::More tests => 43;
+
+use_ok( 'Term::Cap' );
+
+local (*TCOUT, *OUT);
+my $out = tie *OUT, 'TieOut';
+my $writable = 1;
+
+if (open(TCOUT, ">tcout")) {
+ print TCOUT <DATA>;
+ close TCOUT;
+} else {
+ $writable = 0;
+}
+
+# termcap_path -- the names are hardcoded in Term::Cap
+$ENV{TERMCAP} = '';
+my $path = join '', Term::Cap::termcap_path();
+my $files = join '', grep { -f $_ } ( $ENV{HOME} . '/.termcap', '/etc/termcap',
+ '/usr/share/misc/termcap' );
+is( $path, $files, 'termcap_path() found default files okay' );
+
+SKIP: {
+ # this is ugly, but -f $0 really *ought* to work
+ skip("-f $0 fails, some tests difficult now", 2) unless -f $0;
+
+ $ENV{TERMCAP} = $0;
+ ok( grep($0, Term::Cap::termcap_path()), 'found file from $ENV{TERMCAP}' );
+
+ $ENV{TERMCAP} = (grep { $^O eq $_ } qw( os2 MSWin32 dos )) ? 'a:/' : '/';
+ $ENV{TERMPATH} = $0;
+ ok( grep($0, Term::Cap::termcap_path()), 'found file from $ENV{TERMPATH}' );
+}
+
+
+# make a Term::Cap "object"
+my $t = {
+ PADDING => 1,
+ _pc => 'pc',
+};
+bless($t, 'Term::Cap' );
+
+# see if Tpad() works
+is( $t->Tpad(), undef, 'Tpad() is undef with no string' );
+is( $t->Tpad('x'), 'x', 'Tpad() returns strings with no match' );
+is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() pads string fine' );
+
+$t->{PADDING} = 2;
+is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() pad math is okay' );
+is( $out->read(), 'apcpc', 'Tpad() writes to filehandle fine' );
+
+is( $t->Tputs('PADDING'), 2, 'Tputs() returns existing value file' );
+is( $t->Tputs('pc', 2), 'pc', 'Tputs() delegates to Tpad() fine' );
+$t->Tputs('pc', 1, *OUT);
+is( $t->{pc}, 'pc', 'Tputs() caches fine when asked' );
+is( $out->read(), 'pc', 'Tputs() writes to filehandle fine' );
+
+eval { $t->Trequire( 'pc' ) };
+is( $@, '', 'Trequire() finds existing cap fine' );
+eval { $t->Trequire( 'nonsense' ) };
+like( $@, qr/support: \(nonsense\)/, 'Trequire() croaks with unsupported cap' );
+
+my $warn;
+local $SIG{__WARN__} = sub {
+ $warn = $_[0];
+};
+
+# test the first few features by forcing Tgetent() to croak (line 156)
+undef $ENV{TERM};
+my $vals = {};
+eval { $t = Term::Cap->Tgetent($vals) };
+like( $@, qr/TERM not set/, 'Tgetent() croaks without TERM' );
+like( $warn, qr/OSPEED was not set/, 'Tgetent() set default OSPEED value' );
+is( $vals->{PADDING}, 10000/9600, 'Default OSPEED implies default PADDING' );
+
+# check values for very slow speeds
+$vals->{OSPEED} = 1;
+$warn = '';
+eval { $t = Term::Cap->Tgetent($vals) };
+is( $warn, '', 'no warning when passing OSPEED to Tgetent()' );
+is( $vals->{PADDING}, 200, 'Tgetent() set slow PADDING when needed' );
+
+# now see if lines 177 or 180 will fail
+$ENV{TERM} = 'foo';
+$ENV{TERMPATH} = '!';
+$ENV{TERMCAP} = '';
+eval { $t = Term::Cap->Tgetent($vals) };
+isn't( $@, '', 'Tgetent() caught bad termcap file' );
+
+# if there's no valid termcap file found, it should croak
+$vals->{TERM} = '';
+$ENV{TERMPATH} = $0;
+eval { $t = Term::Cap->Tgetent($vals) };
+like( $@, qr/failed termcap lookup/, 'Tgetent() dies with bad termcap file' );
+
+SKIP: {
+ skip( "Can't write 'tcout' file for tests", 8 ) unless $writable;
+
+ # it shouldn't try to read one file more than 32(!) times
+ # see __END__ for a really awful termcap example
+
+ $ENV{TERMPATH} = join(' ', ('tcout') x 33);
+ $vals->{TERM} = 'bar';
+ eval { $t = Term::Cap->Tgetent($vals) };
+ like( $@, qr/failed termcap loop/, 'Tgetent() dies with much recursion' );
+
+ # now let it read a fake termcap file, and see if it sets properties
+ $ENV{TERMPATH} = 'tcout';
+ $vals->{TERM} = 'baz';
+ $t = Term::Cap->Tgetent($vals);
+ is( $t->{_f1}, 1, 'Tgetent() set a single field correctly' );
+ is( $t->{_f2}, 1, 'Tgetent() set another field on the same line' );
+ is( $t->{_no}, '', 'Tgetent() set a blank field correctly' );
+ is( $t->{_k1}, 'v1', 'Tgetent() set a key value pair correctly' );
+ like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() set and translated a pair right' );
+
+ # and it should have set these two fields
+ is( $t->{_pc}, "\0", 'set _pc field correctly' );
+ is( $t->{_bc}, "\b", 'set _bc field correctly' );
+}
+
+# Tgoto has comments on the expected formats
+$t->{_test} = "a%d";
+is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() works with %d code' );
+is( $out->read(), 'a1', 'Tgoto() printed to filehandle fine' );
+
+$t->{_test} = "a%.";
+like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() works with %.' );
+like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/, 'Tgoto() %. and magic work' );
+
+$t->{_test} = 'a%+';
+like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() works with %+' );
+$t->{_test} = 'a%+a';
+is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() works with %+ and a character' );
+$t->{_test} .= 'a' x 99;
+like( $t->Tgoto('test', '', 1), qr/ba{98}/, 'Tgoto() substr()s %+ if needed' );
+
+$t->{_test} = '%ra%d';
+is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() swaps params with %r set' );
+
+$t->{_test} = 'a%>11bc';
+is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() unpacks with %> set' );
+
+$t->{_test} = 'a%21';
+is( $t->Tgoto('test'), 'a001', 'Tgoto() formats with %2 set' );
+
+$t->{_test} = 'a%31';
+is( $t->Tgoto('test'), 'a0001', 'Tgoto() also formats with %3 set' );
+
+$t->{_test} = '%ia%21';
+is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() incremented args with %i set ');
+
+$t->{_test} = '%z';
+is( $t->Tgoto('test'), 'OOPS', 'Tgoto() handled invalid arg fine' );
+
+# and this is pretty standard
+package TieOut;
+
+sub TIEHANDLE {
+ bless( \(my $self), $_[0] );
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+
+sub read {
+ my $self = shift;
+ substr( $$self, 0, length($$self), '' );
+}
+
+__END__
+bar: :tc=bar: \
+baz: \
+:f1: :f2: \
+:no@ \
+:k1#v1\
+:k2=v2\\n2
use warnings;
use Test::More tests => 8;
use vars qw( $Term::Complete::complete $complete );
+my $restore;
+
SKIP: {
skip('PERL_SKIP_TTY_TEST', 8) if $ENV{PERL_SKIP_TTY_TEST};
if (defined $TTY) {
open(TTY, $TTY) or die "open $TTY failed: $!";
skip("$TTY not a tty", 8) if defined $TTY && ! -t TTY;
- }
+ $restore = `stty -g`;
+ skip("Can't reliably restore $TTY", 8) if $?;
+ }
use_ok( 'Term::Complete' );
# now remove the prompt and we should be okay
$$out =~ s/prompt://g;
is( $$out, get_expected('frobn', 'frobnitz' ), 'works with new $complete' );
+`stty $restore`;
+
+} # end of SKIP, end of tests
# easier than matching space characters
sub get_expected {
my $self = shift;
($$self .= join('', @_)) =~ s/\s+/./gm;
}
-
-} # end of SKIP, end of tests
-
--- /dev/null
+= 2001/09/29
+
+Philip Newton <Philip.Newton@gmx.net> sent in a clean patch that
+added support for defining words differently; that prevents
+Text::Wrap from untainting strings; and that fixes a documentation
+bug.
+
+So that fill.t can be used in the version included in the perl
+distribution, fill.t no longer uses File::Slurp.
+
+Both Sweth Chandramouli <svc@sweth.net> and Drew Degentesh
+<ddegentesh@daed.com> both objected to the automatic unexpand
+that Text::Wrap does on its results. Drew sent a patch which
+has been integrated.
+
+Way back in '97, Joel Earl <jrearl@VNET.IBM.COM> asked that
+it be possible to use a line separator other than \n when
+adding new lines. There is now support for that.
+
+= 2001/01/30
+
+Bugfix by Michael G Schwern <schwern@pobox.com>: don't add extra
+whitespace when working one an array of input (as opposed to a
+single string).
+
+Performance rewrite: use m/\G/ rather than s///.
+
+You can now specify that words that are too long to wrap can simply
+overflow the line. Feature requested by James Hoagland
+<hoagland@SiliconDefense.com> and by John Porter <jdporter@min.net>.
+
+Documentation changes from Rich Bowen <Rich@cre8tivegroup.com>.
+
+= 1998/11/29
+
+Combined Fill.pm into Wrap.pm. It appears there are versions of
+Wrap.pm with fill in them.
+
+= 1998/11/28
+
+Over the last couple of years, many people sent in various
+rewrites of Text::Wrap. I should have done something about
+updating it long ago. If someone wants to take it over from
+me, discuss it in perl-porters. I'll be happy to hand it
+over.
+
+Anyway, I have a bunch of people to thank. I didn't
+use what any of them sent in, but I did take ideas from
+all of them. Many sent in complete new implamentations.
+
+ Ivan Brawley <ibrawley@awadi.com.au>
+
+ Jacqui Caren <Jacqui.Caren@ig.co.uk>
+
+ Jeff Kowalski <jeff.kowalski@autodesk.com>
+
+ Allen Smith <easmith@beatrice.rutgers.edu>
+
+ Sullivan N. Beck <sbeck@cise.ufl.edu>
+
+The end result is a very slight change in the API. There
+is now an additional package variable: $Text::Wrap::huge.
+When $huge is set to 'die' then long words will cause
+wrap() to die. When it is set to 'wrap', long words will
+be wrapped. The default is 'wrap'.
+
+<shout>LONG WORDS WILL NOW BE WRAPPED BY DEFAULT</shout>.
+This is a change in behavior.
+
+At the bottom of Text::Wrap, there was a function (fill())
+sitting there unpublished. There was a note that Tim Pierce
+had a faster version, but a search on CPAN failed to turn it
+up. Text::Fill is now available.
+
print "ok $tn\n";
} elsif ($rerun) {
my $oi = $in;
- open(F,">#o") and do { print F $back; close(F) };
- open(F,">#e") and do { print F $out; close(F) };
+ write_file("#o", $back);
+ write_file("#e", $out);
foreach ($in, $back, $out) {
s/\t/^I\t/gs;
s/\n/\$\n/gs;
}
$tn++;
}
+
+sub write_file
+{
+ my ($f, @data) = @_;
+
+ local(*F);
+
+ open(F, ">$f") || die "open >$f: $!";
+ (print F @data) || die "write $f: $!";
+ close(F) || die "close $f: $!";
+ return 1;
+}
@EXPORT = qw(wrap fill);
@EXPORT_OK = qw($columns $break $huge);
-$VERSION = 2001.0131;
+$VERSION = 2001.0929;
-use vars qw($VERSION $columns $debug $break $huge);
+use vars qw($VERSION $columns $debug $break $huge $unexpand $tabstop
+ $separator);
use strict;
BEGIN {
$debug = 0;
$break = '\s';
$huge = 'wrap'; # alternatively: 'die' or 'overflow'
+ $unexpand = 1;
+ $tabstop = 8;
+ $separator = "\n";
}
use Text::Tabs qw(expand unexpand);
{
my ($ip, $xp, @t) = @_;
+ local($Text::Tabs::tabstop) = $tabstop;
my $r = "";
my $tail = pop(@t);
- my $t = expand(join("", (map { /\s+\Z/ ? ( $_ ) : ($_, ' ') } @t), $tail));
+ my $t = expand(join("", (map { /\s+\z/ ? ( $_ ) : ($_, ' ') } @t), $tail));
my $lead = $ip;
my $ll = $columns - length(expand($ip)) - 1;
my $nll = $columns - length(expand($xp)) - 1;
my $nl = "";
my $remainder = "";
+ use re 'taint';
+
pos($t) = 0;
while ($t !~ /\G\s*\Z/gc) {
- if ($t =~ /\G([^\n]{0,$ll})($break|\Z(?!\n))/xmgc) {
- $r .= unexpand($nl . $lead . $1);
+ if ($t =~ /\G([^\n]{0,$ll})($break|\z)/xmgc) {
+ $r .= $unexpand
+ ? unexpand($nl . $lead . $1)
+ : $nl . $lead . $1;
$remainder = $2;
} elsif ($huge eq 'wrap' && $t =~ /\G([^\n]{$ll})/gc) {
- $r .= unexpand($nl . $lead . $1);
- $remainder = "\n";
- } elsif ($huge eq 'overflow' && $t =~ /\G([^\n]*?)($break|\Z(?!\n))/xmgc) {
- $r .= unexpand($nl . $lead . $1);
+ $r .= $unexpand
+ ? unexpand($nl . $lead . $1)
+ : $nl . $lead . $1;
+ $remainder = $separator;
+ } elsif ($huge eq 'overflow' && $t =~ /\G([^\n]*?)($break|\z)/xmgc) {
+ $r .= $unexpand
+ ? unexpand($nl . $lead . $1)
+ : $nl . $lead . $1;
$remainder = $2;
} elsif ($huge eq 'die') {
die "couldn't wrap '$t'";
$lead = $xp;
$ll = $nll;
- $nl = "\n";
+ $nl = $separator;
}
$r .= $remainder;
=head1 DESCRIPTION
-Text::Wrap::wrap() is a very simple paragraph formatter. It formats a
+C<Text::Wrap::wrap()> is a very simple paragraph formatter. It formats a
single paragraph at a time by breaking lines at word boundries.
Indentation is controlled for the first line (C<$initial_tab>) and
all subsquent lines (C<$subsequent_tab>) independently. Please note:
C<$initial_tab> and C<$subsequent_tab> are the literal strings that will
be used: it is unlikley you would want to pass in a number.
+Text::Wrap::fill() is a simple multi-paragraph formatter. It formats
+each paragraph separately and then joins them together when it's done. It
+will destory any whitespace in the original text. It breaks text into
+paragraphs by looking for whitespace after a newline. In other respects
+it acts like wrap().
+
+=head1 OVERRIDES
+
+C<Text::Wrap::wrap()> has a number of variables that control its behavior.
+Because other modules might be using C<Text::Wrap::wrap()> it is suggested
+that you leave these variables alone! If you can't do that, then
+use C<local($Text::Wrap::VARIABLE) = YOURVALUE> when you change the
+values so that the original value is restored. This C<local()> trick
+will not work if you import the variable into your own namespace.
+
Lines are wrapped at C<$Text::Wrap::columns> columns. C<$Text::Wrap::columns>
should be set to the full width of your output device. In fact,
every resulting line will have length of no more than C<$columns - 1>.
+It is possible to control which characters terminate words by
+modifying C<$Text::Wrap::break>. Set this to a string such as
+C<'[\s:]'> (to break before spaces or colons) or a pre-compiled regexp
+such as C<qr/[\s']/> (to break before spaces or apostrophes). The
+default is simply C<'\s'>; that is, words are terminated by spaces.
+(This means, among other things, that trailing punctuation such as
+full stops or commas stay with the word they are "attached" to.)
+
Beginner note: In example 2, above C<$columns> is imported into
the local namespace, and set locally. In example 3,
C<$Text::Wrap::columns> is set in its own namespace without importing it.
+C<Text::Wrap::wrap()> starts its work by expanding all the tabs in its
+input into spaces. The last thing it does it to turn spaces back
+into tabs. If you do not want tabs in your results, set
+C<$Text::Wrap::unexapand> to a false value. Likewise if you do not
+want to use 8-character tabstops, set C<$Text::Wrap::tabstop> to
+the number of characters you do want for your tabstops.
+
+If you want to separate your lines with something other than C<\n>
+then set C<$Text::Wrap::seporator> to your preference.
+
When words that are longer than C<$columns> are encountered, they
are broken up. C<wrap()> adds a C<"\n"> at column C<$columns>.
This behavior can be overridden by setting C<$huge> to
C<die()> to be called. When set to 'overflow', large words will be
left intact.
-Text::Wrap::fill() is a simple multi-paragraph formatter. It formats
-each paragraph separately and then joins them together when it's done. It
-will destory any whitespace in the original text. It breaks text into
-paragraphs by looking for whitespace after a newline. In other respects
-it acts like wrap().
-
-When called in list context, C<wrap()> will return a list of lines and
-C<fill()> will return a list of paragraphs.
-
-Historical notes: Older versions of C<wrap()> and C<fill()> always
-returned strings. Also, 'die' used to be the default value of
+Historical notes: 'die' used to be the default value of
C<$huge>. Now, 'wrap' is the default value.
=head1 EXAMPLE
}
# can't use require_ok() here, with a name like 'open'
-ok( require 'open.pm', 'required okay!' );
+ok( require 'open.pm', 'requiring open' );
# this should fail
eval { import() };
-like( $@, qr/needs explicit list of disciplines/, 'import fails without args' );
+like( $@, qr/needs explicit list of disciplines/,
+ 'import should fail without args' );
# the hint bits shouldn't be set yet
-is( $^H & $open::hint_bits, 0, '$^H is okay before open import runs' );
+is( $^H & $open::hint_bits, 0,
+ 'hint bits should not be set in $^H before open import' );
# prevent it from loading I18N::Langinfo, so we can test encoding failures
local @INC;
-$ENV{LC_ALL} = '';
+$ENV{LC_ALL} = $ENV{LANG} = '';
eval { import( 'IN', 'locale' ) };
-like( $@, qr/Cannot figure out an encoding/, 'no encoding found' );
+like( $@, qr/Cannot figure out an encoding/,
+ 'no encoding should be found without $ENV{LANG} or $ENV{LC_ALL}' );
my $warn;
local $SIG{__WARN__} = sub {
# and it shouldn't be able to find this discipline
eval{ import( 'IN', 'macguffin' ) };
-like( $warn, qr/Unknown discipline layer/, 'warned about unknown discipline' );
+like( $warn, qr/Unknown discipline layer/,
+ 'should warn about unknown discipline with bad discipline provided' );
# now load a real-looking locale
$ENV{LC_ALL} = ' .utf8';
import( 'IN', 'locale' );
-is( ${^OPEN}, ':utf8\0', 'set locale layer okay!' );
+is( ${^OPEN}, ':utf8\0',
+ 'should set a valid locale layer' );
# and see if it sets the magic variables appropriately
import( 'IN', ':crlf' );
-ok( $^H & $open::hint_bits, '$^H is set after open import runs' );
-is( $^H{'open_IN'}, 'crlf', 'set crlf layer okay!' );
+ok( $^H & $open::hint_bits,
+ 'hint bits should be set in $^H after open import' );
+is( $^H{'open_IN'}, 'crlf', 'should have set crlf layer' );
# it should reset them appropriately, too
import( 'IN', ':raw' );
-is( $^H{'open_IN'}, 'raw', 'set raw layer okay!' );
+is( $^H{'open_IN'}, 'raw', 'should have reset to raw layer' );
# it dies if you don't set IN, OUT, or INOUT
eval { import( 'sideways', ':raw' ) };
-like( $@, qr/Unknown discipline class/, 'croaked with unknown class' );
+like( $@, qr/Unknown discipline class/, 'should croak with unknown class' );
# but it handles them all so well together
import( 'INOUT', ':raw :crlf' );
-is( ${^OPEN}, ':raw :crlf\0:raw :crlf', 'multi types, multi disciplines' );
-is( $^H{'open_INOUT'}, 'crlf', 'last layer set in %^H' );
+is( ${^OPEN}, ':raw :crlf\0:raw :crlf',
+ 'should set multi types, multi disciplines' );
+is( $^H{'open_INOUT'}, 'crlf', 'should record last layer set in %^H' );
__END__
# this one won't run as $locale_encoding is already set
# perhaps qx{} it, if it's important to run
$ENV{LC_ALL} = 'nonexistent.euc';
eval { open::_get_locale_encoding() };
-like( $@, qr/too ambiguous/, 'died with ambiguous locale encoding' );
+like( $@, qr/too ambiguous/, 'should die with ambiguous locale encoding' );
package utf8;
-my $DEBUG = 0;
-my $seq = "AAA0000";
+sub DEBUG () { 0 }
sub DESTROY {}
sub SWASHNEW {
my ($class, $type, $list, $minbits, $none) = @_;
local $^D = 0 if $^D;
- print STDERR "SWASHNEW @_\n" if $DEBUG;
- my $extras;
- my $bits;
-
+
+ print STDERR "SWASHNEW @_\n" if DEBUG;
+
+ my $file;
+
if ($type and ref ${"${class}::{$type}"} eq $class) {
- warn qq/Found \${"${class}::{$type}"}\n/ if $DEBUG;
+ warn qq/Found \${"${class}::{$type}"}\n/ if DEBUG;
return ${"${class}::{$type}"}; # Already there...
}
- $type ||= $seq++;
-
- my $caller;
- my $i = 0;
- while (($caller = caller($i)) eq __PACKAGE__) { $i++ }
- my $encoding = $enc{$caller} || "unicore";
- (my $file = $type) =~ s!::!/!g;
- if ($file =~ /^In[- ]?(.+)/i) {
- my $In = $1;
- defined %utf8::In || do "$encoding/In.pl";
- my $prefix = substr(lc($In), 0, 3);
- if (exists $utf8::InPat{$prefix}) {
- for my $k (keys %{$utf8::InPat{$prefix}}) {
+ if ($type) {
+
+ defined %utf8::In || do "unicore/In.pl";
+
+ $type =~ s/^In(?:[-_]|\s+)?//i;
+ $type =~ s/\s+$//;
+
+ my $inprefix = substr(lc($type), 0, 3);
+ if (exists $utf8::InPat{$inprefix}) {
+ my $In = $type;
+ for my $k (keys %{$utf8::InPat{$inprefix}}) {
if ($In =~ /^$k$/i) {
- $In = $utf8::InPat{$prefix}->{$k};
+ $In = $utf8::InPat{$inprefix}->{$k};
if (exists $utf8::In{$In}) {
- $file = "$encoding/In/$utf8::In{$In}";
+ $file = "unicore/In/$utf8::In{$In}";
+ print "inprefix = $inprefix, In = $In, k = $k, file = $file\n" if DEBUG;
last;
}
}
}
}
- } else {
- $file =~ s#^(Is|To)([A-Z].*)#$1/$2#;
+
+ # This is separate from 'To' in preparation of Is.pl (a la In.pl).
+ if ((not defined $file) && $type =~ /^Is([A-Z][A-Za-z]*)$/) {
+ $file = "unicore/Is/$1";
+ }
+
+ if ((not defined $file) && $type =~ /^To([A-Z][A-Za-z]*)$/) {
+ $file = "unicore/To/$1";
+ }
}
{
- $list ||=
- ( exists &{"${caller}::${type}"} &&
- eval { $caller->$type() } )
- || do "$file.pl"
- || do "$encoding/$file.pl"
- || do "$encoding/Is/${type}.pl"
- || croak("Can't find Unicode character property \"$type\"");
+ $list ||= do "$file.pl"
+ || do "unicore/Is/$type.pl"
+ || croak("Can't find Unicode character property \"$type\"");
}
- $| = 1;
-
+ my $extras;
+ my $bits;
+
if ($list) {
my @tmp = split(/^/m, $list);
my %seen;
while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
my $char = $1;
my $name = $2;
- # print STDERR "$1 => $2\n" if $DEBUG;
+# print STDERR "$1 => $2\n" if DEBUG;
if ($char =~ /[-+!]/) {
my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really
my $subobj = $c->SWASHNEW($t, "", 0, 0, 0);
}
}
- print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if $DEBUG;
+ print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG;
${"${class}::{$type}"} = bless {
TYPE => $type,
my $type = $self->{TYPE};
my $bits = $self->{BITS};
my $none = $self->{NONE};
- print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if $DEBUG;
+ print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG;
my $end = $start + $len;
my $swatch = "";
my $key;
}
for ($key = $min; $key <= $max; $key++) {
last LINE if $key >= $end;
-# print STDERR "$key => $val\n" if $DEBUG;
+# print STDERR "$key => $val\n" if DEBUG;
vec($swatch, $key - $start, $bits) = $val;
++$val if $val < $none;
}
}
for ($key = $min; $key <= $max; $key++, $val++) {
last LINE if $key >= $end;
-# print STDERR "$key => $val\n" if $DEBUG;
+# print STDERR "$key => $val\n" if DEBUG;
vec($swatch, $key - $start, $bits) = $val;
}
}
}
for ($key = $min; $key <= $max; $key++) {
last LINE if $key >= $end;
-# print STDERR "$key => 1\n" if $DEBUG;
+# print STDERR "$key => 1\n" if DEBUG;
vec($swatch, $key - $start, 1) = 1;
}
}
while ($x =~ /^([-+!])(.*)/mg) {
my $char = $1;
my $name = $2;
- print STDERR "INDIRECT $1 $2\n" if $DEBUG;
+ print STDERR "INDIRECT $1 $2\n" if DEBUG;
my $otherbits = $self->{$name}->{BITS};
croak("SWASHGET size mismatch") if $bits < $otherbits;
my $other = $self->{$name}->SWASHGET($start, $len);
}
}
}
- if ($DEBUG) {
+ if (DEBUG) {
print STDERR "CELLS ";
for ($key = 0; $key < $len; $key++) {
print STDERR vec($swatch, $key, $bits), " ";
=for hackers
Found in file sharedsv.c
+=item sortsv
+
+
+Sort an array in place. Here is an example:
+
+ sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
+
+ void sortsv(SV ** array, size_t num_elts, SVCOMPARE_t f)
+
+=for hackers
+Found in file pp_ctl.c
+
=item SP
Stack pointer. This is usually handled by C<xsubpp>. See C<dSP> and
=for hackers
Found in file sv.h
-=item SvNVx
+=item SvNVX
-Coerces the given SV to a double and returns it. Guarantees to evaluate
-sv only once. Use the more efficent C<SvNV> otherwise.
+Returns the raw value in the SV's NV slot, without checks or conversions.
+Only use when you are sure SvNOK is true. See also C<SvNV()>.
- NV SvNVx(SV* sv)
+ NV SvNVX(SV* sv)
=for hackers
Found in file sv.h
-=item SvNVX
+=item SvNVx
-Returns the raw value in the SV's NV slot, without checks or conversions.
-Only use when you are sure SvNOK is true. See also C<SvNV()>.
+Coerces the given SV to a double and returns it. Guarantees to evaluate
+sv only once. Use the more efficent C<SvNV> otherwise.
- NV SvNVX(SV* sv)
+ NV SvNVx(SV* sv)
=for hackers
Found in file sv.h
=for hackers
Found in file sv.h
-=item SvPVX
+=item SvPVx
-Returns a pointer to the physical string in the SV. The SV must contain a
-string.
+A version of C<SvPV> which guarantees to evaluate sv only once.
- char* SvPVX(SV* sv)
+ char* SvPVx(SV* sv, STRLEN len)
=for hackers
Found in file sv.h
-=item SvPVx
+=item SvPVX
-A version of C<SvPV> which guarantees to evaluate sv only once.
+Returns a pointer to the physical string in the SV. The SV must contain a
+string.
- char* SvPVx(SV* sv, STRLEN len)
+ char* SvPVX(SV* sv)
=for hackers
Found in file sv.h
=for hackers
Found in file sv.h
-=item svtype
+=item SvTYPE
-An enum of flags for Perl types. These are found in the file B<sv.h>
-in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV. See C<svtype>.
+
+ svtype SvTYPE(SV* sv)
=for hackers
Found in file sv.h
-=item SvTYPE
-
-Returns the type of the SV. See C<svtype>.
+=item svtype
- svtype SvTYPE(SV* sv)
+An enum of flags for Perl types. These are found in the file B<sv.h>
+in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
=for hackers
Found in file sv.h
"elseif" for the class returned by the following block. This is
unlikely to be what you want.
+=item Empty %s
+
+(F) Empty C<\p{}> or C<\P{}>.
+
=item entering effective %s failed
(F) While under the C<use filetest> pragma, switching the real and
(S) This is an educated guess made in conjunction with the message "%s
found where operator expected". Often the missing operator is a comma.
+=item Missing right brace on %s
+
+(F) Missing right brace in C<\p{...}> or C<\P{...}>.
+
=item Missing right curly or square bracket
(F) The lexer counted more opening curly or square brackets than closing
=head1 NAME
-perlfaq3 - Programming Tools ($Revision: 1.1 $, $Date: 2001/09/20 03:03:00 $)
+perlfaq3 - Programming Tools ($Revision: 1.2 $, $Date: 2001/09/29 03:13:13 $)
=head1 DESCRIPTION
distribution. You can find out whether you are using perl's malloc by
typing C<perl -V:usemymalloc>.
+Of course, the best way to save memory is to not do anything to waste
+it in the first place. Good programming practices can go a long way
+toward this:
+
+=over 4
+
+=item * Don't slurp!
+
+Don't read an entire file into memory if you can process it line
+by line. Or more concretely, use a loop like this:
+
+ #
+ # Good Idea
+ #
+ while (<FILE>) {
+ # ...
+ }
+
+instead of this:
+
+ #
+ # Bad Idea
+ #
+ @data = <FILE>;
+ foreach (@data) {
+ # ...
+ }
+
+When the files you're processing are small, it doesn't much matter which
+way you do it, but it makes a huge difference when they start getting
+larger.
+
+=item * Pass by reference
+
+Pass arrays and hashes by reference, not by value. For one thing, it's
+the only way to pass multiple lists or hashes (or both) in a single
+call/return. It also avoids creating a copy of all the contents. This
+requires some judgment, however, because any changes will be propagated
+back to the original data. If you really want to mangle (er, modify) a
+copy, you'll have to sacrifice the memory needed to make one.
+
+=item * Tie large variables to disk.
+
+For "big" data stores (i.e. ones that exceed available memory) consider
+using one of the DB modules to store it on disk instead of in RAM. This
+will incur a penalty in access time, but that's probably better that
+causing your hard disk to thrash due to massive swapping.
+
+=back
+
=head2 Is it unsafe to return a pointer to local data?
No, Perl's garbage collection system takes care of this.
=head1 NAME
-perlfaq4 - Data Manipulation ($Revision: 1.1 $, $Date: 2001/09/20 03:03:00 $)
+perlfaq4 - Data Manipulation ($Revision: 1.2 $, $Date: 2001/09/26 15:42:12 $)
=head1 DESCRIPTION
This has the strange effect of turning "C<don't do it>" into "C<Don'T
Do It>". Sometimes you might want this. Other times you might need a
-more thorough solution (Suggested by brian d. foy):
+more thorough solution (Suggested by brian d foy):
$string =~ s/ (
(^\w) #at the beginning of the line
=head1 NAME
-perlfaq5 - Files and Formats ($Revision: 1.1 $, $Date: 2001/09/20 03:03:00 $)
+perlfaq5 - Files and Formats ($Revision: 1.2 $, $Date: 2001/09/26 10:44:41 $)
=head1 DESCRIPTION
This one will do it for you:
sub commify {
- local $_ = shift;
- 1 while s/^([-+]?\d+)(\d{3})/$1,$2/;
- return $_;
+ my $number = shift;
+ 1 while ($number =~ s/^([-+]?\d+)(\d{3})/$1,$2/);
+ return $number;
}
$n = 23659019423.2331;
=head1 NAME
-perlfaq9 - Networking ($Revision: 1.1 $, $Date: 2001/09/20 03:03:00 $)
+perlfaq9 - Networking ($Revision: 1.2 $, $Date: 2001/09/28 06:40:07 $)
=head1 DESCRIPTION
This section deals with questions related to networking, the internet,
and a few on the web.
-=head2 My CGI script runs from the command line but not the browser. (500 Server Error)
+=head2 What is the correct form of response from a CGI script?
-If you can demonstrate that you've read the following FAQs and that
-your problem isn't something simple that can be easily answered, you'll
-probably receive a courteous and useful reply to your question if you
-post it on comp.infosystems.www.authoring.cgi (if it's something to do
-with HTTP, HTML, or the CGI protocols). Questions that appear to be Perl
-questions but are really CGI ones that are posted to comp.lang.perl.misc
-may not be so well received.
+(Alan Flavell <flavell+www@a5.ph.gla.ac.uk> answers...)
-The useful FAQs and related documents are:
+The Common Gateway Interface (CGI) specifies a software interface between
+a program ("CGI script") and a web server (HTTPD). It is not specific
+to Perl, and has its own FAQs and tutorials, and usenet group,
+comp.infosystems.www.authoring.cgi
- CGI FAQ
- http://www.webthing.com/tutorials/cgifaq.html
+The original CGI specification is at: http://hoohoo.ncsa.uiuc.edu/cgi/
- Web FAQ
- http://www.boutell.com/faq/
+Current best-practice RFC draft at: http://CGI-Spec.Golux.Com/
- WWW Security FAQ
- http://www.w3.org/Security/Faq/
+Other relevant documentation listed in: http://www.perl.org/CGI_MetaFAQ.html
- HTTP Spec
- http://www.w3.org/pub/WWW/Protocols/HTTP/
+These Perl FAQs very selectively cover some CGI issues. However, Perl
+programmers are strongly advised to use the CGI.pm module, to take care
+of the details for them.
- HTML Spec
- http://www.w3.org/TR/REC-html40/
- http://www.w3.org/pub/WWW/MarkUp/
+The similarity between CGI response headers (defined in the CGI
+specification) and HTTP response headers (defined in the HTTP
+specification, RFC2616) is intentional, but can sometimes be confusing.
- CGI Spec
- http://www.w3.org/CGI/
+The CGI specification defines two kinds of script: the "Parsed Header"
+script, and the "Non Parsed Header" (NPH) script. Check your server
+documentation to see what it supports. "Parsed Header" scripts are
+simpler in various respects. The CGI specification allows any of the
+usual newline representations in the CGI response (it's the server's
+job to create an accurate HTTP response based on it). So "\n" written in
+text mode is technically correct, and recommended. NPH scripts are more
+tricky: they must put out a complete and accurate set of HTTP
+transaction response headers; the HTTP specification calls for records
+to be terminated with carriage-return and line-feed, i.e ASCII \015\012
+written in binary mode.
+
+Using CGI.pm gives excellent platform independence, including EBCDIC
+systems. CGI.pm selects an appropriate newline representation
+($CGI::CRLF) and sets binmode as appropriate.
+
+=head2 My CGI script runs from the command line but not the browser. (500 Server Error)
+
+If you can demonstrate that you've read the FAQs and that
+your problem isn't something simple that can be easily answered, you'll
+probably receive a courteous and useful reply to your question if you
+post it on comp.infosystems.www.authoring.cgi (if it's something to do
+with HTTP or the CGI protocols). Questions that appear to be Perl
+questions but are really CGI ones that are posted to comp.lang.perl.misc
+are not so well received.
+
+The useful FAQs, related documents, and troubleshooting guides are
+listed in the CGI Meta FAQ:
+
+ http://www.perl.org/CGI_MetaFAQ.html
- CGI Security FAQ
- http://www.go2net.com/people/paulp/cgi-security/safe-cgi.txt
=head2 How can I get better error messages from a CGI program?
=head2 How do I redirect to another page?
-According to RFC 2616, "Hypertext Transfer Protocol -- HTTP/1.1", the
-preferred method is to send a C<Location:> header instead of a
-C<Content-Type:> header:
+Specify the complete URL of the destination (even if it is on the same
+server). This is one of the two different kinds of CGI "Location:"
+responses which are defined in the CGI specification for a Parsed Headers
+script. The other kind (an absolute URLpath) is resolved internally to
+the server without any HTTP redirection. The CGI specifications do not
+allow relative URLs in either case.
- Location: http://www.domain.com/newpage
+Use of CGI.pm is strongly recommended. This example shows redirection
+with a complete URL. This redirection is handled by the web browser.
-Note that relative URLs in these headers can cause strange effects
-because of "optimizations" that servers do.
+ use CGI qw/:standard/;
- $url = "http://www.perl.com/CPAN/";
- print "Location: $url\n\n";
- exit;
+ my $url = 'http://www.perl.com/CPAN/';
+ print redirect($url);
-To target a particular frame in a frameset, include the "Window-target:"
-in the header.
- print <<EOF;
- Location: http://www.domain.com/newpage
- Window-target: <FrameName>
+This example shows a redirection with an absolute URLpath. This
+redirection is handled by the local web server.
- EOF
+ my $url = '/CPAN/index.html';
+ print redirect($url);
+
+
+But if coded directly, it could be as follows (the final "\n" is
+shown separately, for clarity), using either a complete URL or
+an absolute URLpath.
+
+ print "Location: $url\n"; # CGI response header
+ print "\n"; # end of headers
-To be correct to the spec, each of those virtual newlines should
-really be physical C<"\015\012"> sequences by the time your message is
-received by the client browser. Except for NPH scripts, though, that
-local newline should get translated by your server into standard form,
-so you shouldn't have a problem here, even if you are stuck on MacOS.
-Everybody else probably won't even notice.
=head2 How do I put a password on my web pages?
=head2 How do I make sure users can't enter values into a form that cause my CGI script to do bad things?
-Read the CGI security FAQ, at
-http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html , and the
-Perl/CGI FAQ at
-http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html .
+See the security references listed in the CGI Meta FAQ
-In brief: use tainting (see L<perlsec>), which makes sure that data
-from outside your script (eg, CGI parameters) are never used in
-C<eval> or C<system> calls. In addition to tainting, never use the
-single-argument form of system() or exec(). Instead, supply the
-command and arguments as a list, which prevents shell globbing.
+ http://www.perl.org/CGI_MetaFAQ.html
=head2 How do I parse a mail header?
# In the main program
push @INC, new Foo(...);
+Note that these hooks are also permitted to set the %INC entry
+corresponding to the files they have loaded. See L<perlvar/%INC>.
+
For a yet-more-powerful import facility, see L</use> and L<perlmod>.
=item reset EXPR
=item *
+Allow for long form of the General Category Properties, e.g
+C<\p{IsOpenPunctuation}>, not just the abbreviated form, e.g.
+C<\p{IsPs}>.
+
+=item *
+
+Allow for the metaproperties C<Any> and C<Assigned>, and C<Common>;
+C<Alphabetic>, C<Ideographic>, C<Lowercase>, C<Uppercase> (note that
+are large classes than the general categories C<Lu> and C<Ll>),
+C<White Space>, C<Bidi Control>, C<Join Control>, C<ASCII Hex Digit>,
+C<Hex Digit>, <Noncharacter Code Point>, C<ID Start>, C<ID Continue>,
+C<XID Start>, C<XID Continue>, C<NF*_NO>, C<NF*_MAYBE>.
+
+There are also enumerated properties: C<Decomposition Type>,
+C<Numeric Type>, C<East Asian Width>, C<Line Break>. These
+properties have multiple values: for uniqueness the property
+value should be appended. For example, C<\p{IsAlphabetic}>
+wouldbe the binary property, while C<\p{AlphabeticLineBreak}>
+would mean the enumerated property.
+
+=item *
+
Case Mappings? http://www.unicode.org/unicode/reports/tr21/
lc(), uc(), lcfirst(), and ucfirst() work only for some of the
=back
See L<perlunicode/UNICODE REGULAR EXPRESSION SUPPORT LEVEL> for what's
-there and what's missing.
+there and what's missing. Almost all of Levels 2 and 3 is missing,
+and as of 5.8.0 not even all of Level 1 is there.
=head2 use Thread for iThreads
character with the Unicode uppercase property, while C<\p{M}> matches
any mark character. Single letter properties may omit the brackets,
so that can be written C<\pM> also. Many predefined character classes
-are available, such as C<\p{IsMirrored}> and C<\p{InTibetan}>. The
-recommended names of the C<In> classes are the official Unicode script
-and block names but with all non-alphanumeric characters removed, for
-example the block name C<"Latin-1 Supplement"> becomes
-C<\p{InLatin1Supplement}>.
+are available, such as C<\p{IsMirrored}> and C<\p{InTibetan}>.
-Here is the list as of Unicode 3.1.0 (the two-letter classes) and
+The C<\p{Is...}> test for "general properties" such as "letter",
+"digit", while the C<\p{In...}> test for Unicode scripts and blocks.
+
+The official Unicode script and block names have spaces and
+dashes and separators, but for convenience you can have
+dashes, spaces, and underbars at every word division, and
+you need not care about correct casing. It is recommended,
+however, that for consistency you use the following naming:
+the official Unicode script or block name (see below for
+the additional rules that apply to block names), with the whitespace
+and dashes removed, and the words "uppercase-first-lowercase-otherwise".
+That is, "Latin-1 Supplement" becomes "Latin1Supplement".
+
+You can also negate both C<\p{}> and C<\P{}> by introducing a caret
+(^) between the first curly and the property name: C<\p{^InTamil}> is
+equal to C<\P{InTamil}>.
+
+The C<In> can be left out: C<\p{Greek}> is equal to C<\p{InGreek}>.
+
+Here is the list as of Unicode 3.1.1 (the two-letter classes) and
as defined by Perl (the one-letter classes) (in Unicode materials
what Perl calls C<L> is often called C<L&>):
If the file was loaded via a hook (e.g. a subroutine reference, see
L<perlfunc/require> for a description of these hooks), this hook is
-inserted into %INC in place of a filename.
+by default inserted into %INC in place of a filename. Note, however,
+that the hook may have set the %INC entry by itself to provide some more
+specific info.
=item %ENV
cx->blk_sub.oldcurpad = PL_curpad;
cx->blk_sub.argarray = av;
}
- qsortsv((myorigmark+1), max,
- is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
+ sortsv((myorigmark+1), max,
+ is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
POPBLOCK(cx,PL_curpm);
PL_stack_sp = newsp;
else {
if (max > 1) {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- qsortsv(ORIGMARK+1, max,
- (PL_op->op_private & OPpSORT_NUMERIC)
+ sortsv(ORIGMARK+1, max,
+ (PL_op->op_private & OPpSORT_NUMERIC)
? ( (PL_op->op_private & OPpSORT_INTEGER)
? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
: ( overloading ? amagic_ncmp : sv_ncmp))
** They make convenient temporary pointers in other places.
*/
-STATIC void
-S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
+/*
+=for apidoc sortsv
+
+Sort an array in place. Here is an example:
+
+ sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
+
+=cut
+*/
+
+void
+Perl_sortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp)
{
int i, run;
int sense;
;
PERL_CALLCONV SV* Perl_vmess(pTHX_ const char* pat, va_list* args);
PERL_CALLCONV void Perl_qerror(pTHX_ SV* err);
+PERL_CALLCONV void Perl_sortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t f);
PERL_CALLCONV int Perl_mg_clear(pTHX_ SV* sv);
PERL_CALLCONV int Perl_mg_copy(pTHX_ SV* sv, SV* nsv, const char* key, I32 klen);
PERL_CALLCONV MAGIC* Perl_mg_find(pTHX_ SV* sv, int type);
STATIC void S_save_lines(pTHX_ AV *array, SV *sv);
STATIC OP* S_doeval(pTHX_ int gimme, OP** startop);
STATIC PerlIO * S_doopen_pmc(pTHX_ const char *name, const char *mode);
-STATIC void S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t f);
#endif
#if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
if (!RExC_end) {
RExC_parse += 2;
RExC_end = oldregxend;
- vFAIL("Missing right brace on \\p{}");
+ vFAIL2("Missing right brace on \\%c{}", UCHARAT(RExC_parse - 2));
}
RExC_end++;
}
/* FALL THROUGH */
default:
if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p))
- vWARN2(p +1, "Unrecognized escape \\%c passed through", *p);
+ vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
goto normal_default;
}
break;
if (*RExC_parse == '{') {
e = strchr(RExC_parse++, '}');
if (!e)
- vFAIL("Missing right brace on \\p{}");
+ vFAIL2("Missing right brace on \\%c{}", value);
+ while (isSPACE(UCHARAT(RExC_parse)))
+ RExC_parse++;
+ if (e == RExC_parse)
+ vFAIL2("Empty \\%c{}", value);
n = e - RExC_parse;
+ while (isSPACE(UCHARAT(RExC_parse + n - 1)))
+ n--;
}
else {
e = RExC_parse;
n = 1;
}
if (!SIZE_ONLY) {
+ if (UCHARAT(RExC_parse) == '^') {
+ RExC_parse++;
+ n--;
+ value = value == 'p' ? 'P' : 'p'; /* toggle */
+ while (isSPACE(UCHARAT(RExC_parse))) {
+ RExC_parse++;
+ n--;
+ }
+ }
if (value == 'p')
- Perl_sv_catpvf(aTHX_ listsv,
- "+utf8::%.*s\n", (int)n, RExC_parse);
+ Perl_sv_catpvf(aTHX_ listsv,
+ "+utf8::%.*s\n", (int)n, RExC_parse);
else
- Perl_sv_catpvf(aTHX_ listsv,
- "!utf8::%.*s\n", (int)n, RExC_parse);
+ Perl_sv_catpvf(aTHX_ listsv,
+ "!utf8::%.*s\n", (int)n, RExC_parse);
}
RExC_parse = e + 1;
ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
#define sv_utf8_upgrade_macro(sv) sv_utf8_upgrade_flags(sv, SV_GMAGIC)
/* function style also available for sourcecompat */
+#undef sv_setsv
#define sv_setsv(dsv, ssv) sv_setsv_macro(dsv, ssv)
+#undef sv_catsv
#define sv_catsv(dsv, ssv) sv_catsv_macro(dsv, ssv)
+#undef sv_catpvn
#define sv_catpvn(dsv, sstr, slen) sv_catpvn_macro(dsv, sstr, slen)
+#undef sv_2pv
#define sv_2pv(sv, lp) sv_2pv_macro(sv, lp)
+#undef sv_pvn_force
#define sv_pvn_force(sv, lp) sv_pvn_force_macro(sv, lp)
+#undef sv_utf8_upgrade
#define sv_utf8_upgrade(sv) sv_utf8_upgrade_macro(sv)
#undef SvPV
use File::Spec;
require "test.pl";
-plan(tests => 39);
+plan(tests => 43);
my @tempfiles = ();
is( $INC{'Quux2.pm'}, $sref, ' key is correct in %INC' );
pop @INC;
+
+push @INC, sub {
+ my ($self, $filename) = @_;
+ if (substr($filename,0,4) eq 'Toto') {
+ $INC{$filename} = 'xyz';
+ return get_temp_fh($filename);
+ }
+ else {
+ return undef;
+ }
+};
+
+ok( eval { require Toto; 1 }, 'require() magic via anonymous code ref' );
+ok( exists $INC{'Toto.pm'}, ' %INC sees it' );
+ok( ! ref $INC{'Toto.pm'}, q/ key isn't a ref in %INC/ );
+is( $INC{'Toto.pm'}, 'xyz', ' key is correct in %INC' );
+
+pop @INC;
$| = 1;
-print "1..716\n";
+print "1..730\n";
BEGIN {
chdir 't' if -d 't';
print "ok 715\n";
}
+print "# some Unicode properties\n";
+
{
+ # Dashes, underbars, case.
print "not " unless "\x80" =~ /\p{in-latin1_SUPPLEMENT}/;
print "ok 716\n";
+
+ # Complement, leading and trailing whitespace.
+ print "not " unless "\x80" =~ /\P{ ^ In Latin 1 Supplement }/;
+ print "ok 717\n";
+
+ # No ^In, dashes, case.
+ print "not " unless "\x80" =~ /\p{latin-1-supplement}/;
+ print "ok 718\n";
+}
+
+{
+ print "not " unless "a" =~ /\pL/;
+ print "ok 719\n";
+
+ print "not " unless "a" =~ /\p{IsLl}/;
+ print "ok 720\n";
+
+ print "not " if "a" =~ /\p{IsLu}/;
+ print "ok 721\n";
+
+ print "not " unless "A" =~ /\pL/;
+ print "ok 722\n";
+
+ print "not " unless "A" =~ /\p{IsLu}/;
+ print "ok 723\n";
+
+ print "not " if "A" =~ /\p{IsLl}/;
+ print "ok 724\n";
+
+ print "not " if "a" =~ /\PL/;
+ print "ok 725\n";
+
+ print "not " if "a" =~ /\P{IsLl}/;
+ print "ok 726\n";
+
+ print "not " unless "a" =~ /\P{IsLu}/;
+ print "ok 727\n";
+
+ print "not " if "A" =~ /\PL/;
+ print "ok 728\n";
+
+ print "not " if "A" =~ /\P{IsLu}/;
+ print "ok 729\n";
+
+ print "not " unless "A" =~ /\P{IsLl}/;
+ print "ok 730\n";
}
projects / p5sagit/p5-mst-13.2.git / commitdiff