}
}
*d='\0';
- sv_setpvn(sv, dstart, d - dstart);
+ sv_setpvn(sv, (const char*)dstart, d - dstart);
SvUTF8_on(sv);
SvLEN_set(sv, 2*len+1);
SvSETMAGIC(sv);
s += UTF8SKIP(s);
}
*d = '\0';
- sv_setpvn(sv, dstart, d - dstart);
+ sv_setpvn(sv, (const char*)dstart, d - dstart);
SvSETMAGIC(sv);
if (isutf)
SvUTF8_on(sv);
#define append_elem Perl_append_elem
#define append_list Perl_append_list
#define apply Perl_apply
+#define apply_attrs_string Perl_apply_attrs_string
#define avhv_delete_ent Perl_avhv_delete_ent
#define avhv_exists_ent Perl_avhv_exists_ent
#define avhv_fetch_ent Perl_avhv_fetch_ent
#define cv_dump S_cv_dump
#define cv_clone2 S_cv_clone2
#define scalar_mod_type S_scalar_mod_type
+#define method_2entersub S_method_2entersub
#define my_kid S_my_kid
#define dup_attrlist S_dup_attrlist
#define apply_attrs S_apply_attrs
#define scan_trans S_scan_trans
#define scan_word S_scan_word
#define skipspace S_skipspace
+#define swallow_bom S_swallow_bom
#define checkcomma S_checkcomma
#define force_ident S_force_ident
#define incline S_incline
#define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c)
#define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c)
#define apply(a,b,c) Perl_apply(aTHX_ a,b,c)
+#define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d)
#define avhv_delete_ent(a,b,c,d) Perl_avhv_delete_ent(aTHX_ a,b,c,d)
#define avhv_exists_ent(a,b,c) Perl_avhv_exists_ent(aTHX_ a,b,c)
#define avhv_fetch_ent(a,b,c,d) Perl_avhv_fetch_ent(aTHX_ a,b,c,d)
#define cv_dump(a) S_cv_dump(aTHX_ a)
#define cv_clone2(a,b) S_cv_clone2(aTHX_ a,b)
#define scalar_mod_type(a,b) S_scalar_mod_type(aTHX_ a,b)
+#define method_2entersub(a,b,c) S_method_2entersub(aTHX_ a,b,c)
#define my_kid(a,b) S_my_kid(aTHX_ a,b)
#define dup_attrlist(a) S_dup_attrlist(aTHX_ a)
#define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c)
#define scan_trans(a) S_scan_trans(aTHX_ a)
#define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e)
#define skipspace(a) S_skipspace(aTHX_ a)
+#define swallow_bom(a) S_swallow_bom(aTHX_ a)
#define checkcomma(a,b,c) S_checkcomma(aTHX_ a,b,c)
#define force_ident(a,b) S_force_ident(aTHX_ a,b)
#define incline(a) S_incline(aTHX_ a)
#define append_list Perl_append_list
#define Perl_apply CPerlObj::Perl_apply
#define apply Perl_apply
+#define Perl_apply_attrs_string CPerlObj::Perl_apply_attrs_string
+#define apply_attrs_string Perl_apply_attrs_string
#define Perl_avhv_delete_ent CPerlObj::Perl_avhv_delete_ent
#define avhv_delete_ent Perl_avhv_delete_ent
#define Perl_avhv_exists_ent CPerlObj::Perl_avhv_exists_ent
#define cv_clone2 S_cv_clone2
#define S_scalar_mod_type CPerlObj::S_scalar_mod_type
#define scalar_mod_type S_scalar_mod_type
+#define S_method_2entersub CPerlObj::S_method_2entersub
+#define method_2entersub S_method_2entersub
#define S_my_kid CPerlObj::S_my_kid
#define my_kid S_my_kid
#define S_dup_attrlist CPerlObj::S_dup_attrlist
#define scan_word S_scan_word
#define S_skipspace CPerlObj::S_skipspace
#define skipspace S_skipspace
+#define S_swallow_bom CPerlObj::S_swallow_bom
+#define swallow_bom S_swallow_bom
#define S_checkcomma CPerlObj::S_checkcomma
#define checkcomma S_checkcomma
#define S_force_ident CPerlObj::S_force_ident
p |OP* |append_elem |I32 optype|OP* head|OP* tail
p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last
p |I32 |apply |I32 type|SV** mark|SV** sp
+Afp |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len
Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash
Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash
s |char* |scan_word |char *s|char *dest|STRLEN destlen \
|int allow_package|STRLEN *slp
s |char* |skipspace |char *s
+s |char* |swallow_bom |char *s
s |void |checkcomma |char *s|char *name|char *what
s |void |force_ident |char *s|int kind
s |void |incline |char *s
$pat = $_ unless defined $pat;
# extract patterns
+ $pat =~ s/^\s+//; # Protect against empty elements in
+ $pat =~ s/\s+$//; # things like < *.c> and <*.c >.
+ # These alone shouldn't trigger ParseWords.
if ($pat =~ /\s/) {
# XXX this is needed for compatibility with the csh
# implementation in Perl. Need to support a flag
# Match an XS keyword
$BLOCK_re= '\s*(' . join('|', qw(
REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
- CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+ CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL
)) . "|$END)\\s*:";
if $line ;
}
+sub ATTRS_handler ()
+{
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ push @Attributes, $_;
+ }
+}
+
sub ALIAS_handler ()
{
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
last;
}
$XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
- %XsubAliases = %XsubAliasValues = %Interfaces = ();
+ %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
$DoSetMagic = 1;
$orig_args =~ s/\\\s*/ /g; # process line continuations
$gotRETVAL = 0;
INPUT_handler() ;
- process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ;
+ process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ;
print Q<<"EOF" if $ScopeThisXSUB;
# ENTER;
}
print $deferred;
- process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
+ process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
if (check_keyword("PPCODE")) {
print_section();
# $wantRETVAL set if 'RETVAL =' autogenerated
($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
undef %outargs ;
- process_keyword("POSTCALL|OUTPUT|ALIAS|PROTOTYPE");
+ process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE");
# all OUTPUT done, so now push the return value on the stack
if ($gotRETVAL && $RETVAL_code) {
generate_output($var_types{$_}, $num++, $_, 0, 1) for @in_out;
# do cleanup
- process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
+ process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ;
print Q<<"EOF" if $ScopeThisXSUB;
# ]]
EOF
}
}
+ elsif (@Attributes) {
+ push(@InitFileCode, Q<<"EOF");
+# cv = newXS(\"$pname\", XS_$Full_func_name, file);
+# apply_attrs_string("$Package", cv, "@Attributes", 0);
+EOF
+ }
elsif ($interface) {
while ( ($name, $value) = each %Interfaces) {
$name = "$Package\::$name" unless $name =~ /::/;
parameters, a variable number of hosts may be pinged multiple
times and then the connection is closed.
-You may choose one of three different protocols to use for the ping.
+You may choose one of three different protocols to use for the
+ping. The "udp" protocol is the default. Note that a live remote host
+may still fail to be pingable by one or more of these protocols. For
+example, www.microsoft.com is generally alive but not pingable.
+
With the "tcp" protocol the ping() method attempts to establish a
connection to the remote host's echo port. If the connection is
successfully established, the remote host is considered reachable. No
} elsif( $func eq 'E' ){
# E<x> - convert to character
- $$rstr =~ s/^(\w+)>//;
- $res = "&$1;";
+ $$rstr =~ s/^([^>]*)>//;
+ my $escape = $1;
+ $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i;
+ $res = "&$escape;";
} elsif( $func eq 'F' ){
# F<filename> - italizice
$res .= $$rstr;
} elsif( $func eq 'E' ){
# E<x> - convert to character
- $$rstr =~ s/^(\w+)>//;
+ $$rstr =~ s/^([^>]*)>//;
$res .= $E2c{$1} || "";
} elsif( $func eq 'X' ){
# X<> - ignore
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
+ 'sol' => '/', # solidus
+ 'verbar' => '|', # vertical bar
'Aacute' => "A\\*'", # capital A, acute accent
'aacute' => "a\\*'", # small a, acute accent
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
+ 'sol' => '/', # solidus
+ 'verbar' => '|', # vertical bar
"Aacute" => "\xC1", # capital A, acute accent
"aacute" => "\xE1", # small a, acute accent
@EXPORT = qw(wrap fill);
@EXPORT_OK = qw($columns $break $huge);
-$VERSION = 98.112902;
+$VERSION = 2000.06292219; #GMT
use vars qw($VERSION $columns $debug $break $huge);
use strict;
my $remainder = "";
while ($t !~ /^\s*$/) {
- if ($t =~ s/^([^\n]{0,$ll})($break|\Z(?!\n))//xm) {
+ if ($t =~ s/^([^\n]{0,$ll})($break|\Z(?!\n))//x) {
$r .= unexpand($nl . $lead . $1);
$remainder = $2;
} elsif ($huge eq 'wrap' && $t =~ s/^([^\n]{$ll})//) {
#define Perl_Gv_AMupdate pPerl->Perl_Gv_AMupdate
#undef Gv_AMupdate
#define Gv_AMupdate Perl_Gv_AMupdate
+#undef Perl_apply_attrs_string
+#define Perl_apply_attrs_string pPerl->Perl_apply_attrs_string
+#undef apply_attrs_string
+#define apply_attrs_string Perl_apply_attrs_string
#undef Perl_avhv_delete_ent
#define Perl_avhv_delete_ent pPerl->Perl_avhv_delete_ent
#undef avhv_delete_ent
LEAVE;
}
+void
+Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
+ char *attrstr, STRLEN len)
+{
+ OP *attrs = Nullop;
+
+ if (!len) {
+ len = strlen(attrstr);
+ }
+
+ while (len) {
+ for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
+ if (len) {
+ char *sstr = attrstr;
+ for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
+ attrs = append_elem(OP_LIST, attrs,
+ newSVOP(OP_CONST, 0,
+ newSVpvn(sstr, attrstr-sstr)));
+ }
+ }
+
+ Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ Nullsv, prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newRV((SV*)cv)),
+ attrs)));
+}
+
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs)
{
return ((CPerlObj*)pPerl)->Perl_Gv_AMupdate(stash);
}
+#undef Perl_apply_attrs_string
+void
+Perl_apply_attrs_string(pTHXo_ char *stashpv, CV *cv, char *attrstr, STRLEN len)
+{
+ ((CPerlObj*)pPerl)->Perl_apply_attrs_string(stashpv, cv, attrstr, len);
+}
+
#undef Perl_avhv_delete_ent
SV*
Perl_avhv_delete_ent(pTHXo_ AV *ar, SV* keysv, I32 flags, U32 hash)
In the first form, the return value of EXPR is parsed and executed as if it
were a little Perl program. The value of the expression (which is itself
determined within scalar context) is first parsed, and if there weren't any
-errors, executed in the context of the current Perl program, so that any
-variable settings or subroutine and format definitions remain afterwards.
-Note that the value is parsed every time the eval executes. If EXPR is
-omitted, evaluates C<$_>. This form is typically used to delay parsing
-and subsequent execution of the text of EXPR until run time.
+errors, executed in the lexical context of the current Perl program, so
+that any variable settings or subroutine and format definitions remain
+afterwards. Note that the value is parsed every time the eval executes.
+If EXPR is omitted, evaluates C<$_>. This form is typically used to
+delay parsing and subsequent execution of the text of EXPR until run time.
In the second form, the code within the BLOCK is parsed only once--at the
same time the code surrounding the eval itself was parsed--and executed
@foo = grep {!/^#/} @bar; # weed out comments
-Note that, because C<$_> is a reference into the list value, it can
-be used to modify the elements of the array. While this is useful and
-supported, it can cause bizarre results if the LIST is not a named array.
+Note that C<$_> is an alias to the list value, so it can be used to
+modify the elements of the LIST. While this is useful and supported,
+it can cause bizarre results if the elements of LIST are not variables.
Similarly, grep returns aliases into the original list, much as a for
loop's index variable aliases the list elements. That is, modifying an
element of a list returned by grep (for example, in a C<foreach>, C<map>
$hash{getkey($_)} = $_;
}
-Note that, because C<$_> is a reference into the list value, it can
-be used to modify the elements of the array. While this is useful and
-supported, it can cause bizarre results if the LIST is not a named array.
+Note that C<$_> is an alias to the list value, so it can be used to
+modify the elements of the LIST. While this is useful and supported,
+it can cause bizarre results if the elements of LIST are not variables.
Using a regular C<foreach> loop for this purpose would be clearer in
most cases. See also L</grep> for an array composed of those items of
the original list for which the BLOCK or EXPR evaluates to true.
Like many languages, Perl provides for user-defined subroutines.
These may be located anywhere in the main program, loaded in from
other files via the C<do>, C<require>, or C<use> keywords, or
-generated on the fly using C<eval> or anonymous subroutines (closures).
+generated on the fly using C<eval> or anonymous subroutines.
You can even call a function indirectly using a variable containing
its name or a CODE reference.
=head2 Tying Hashes
-As the first Perl data type to be tied (see dbmopen()), hashes have the
-most complete and useful tie() implementation. A class implementing a
-tied hash should define the following methods: TIEHASH is the constructor.
-FETCH and STORE access the key and value pairs. EXISTS reports whether a
-key is present in the hash, and DELETE deletes one. CLEAR empties the
-hash by deleting all the key and value pairs. FIRSTKEY and NEXTKEY
-implement the keys() and each() functions to iterate over all the keys.
-And DESTROY is called when the tied variable is garbage collected.
+Hashes were the first Perl data type to be tied (see dbmopen()). A class
+implementing a tied hash should define the following methods: TIEHASH is
+the constructor. FETCH and STORE access the key and value pairs. EXISTS
+reports whether a key is present in the hash, and DELETE deletes one.
+CLEAR empties the hash by deleting all the key and value pairs. FIRSTKEY
+and NEXTKEY implement the keys() and each() functions to iterate over all
+the keys. And DESTROY is called when the tied variable is garbage
+collected.
If this seems like a lot, then feel free to inherit from merely the
standard Tie::Hash module for most of your methods, redefining only the
PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail);
PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last);
PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp);
+PERL_CALLCONV void Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, char *attrstr, STRLEN len)
+#ifdef CHECK_FORMAT
+ __attribute__((format(printf,pTHX_3,pTHX_4)))
+#endif
+;
PERL_CALLCONV SV* Perl_avhv_delete_ent(pTHX_ AV *ar, SV* keysv, I32 flags, U32 hash);
PERL_CALLCONV bool Perl_avhv_exists_ent(pTHX_ AV *ar, SV* keysv, U32 hash);
PERL_CALLCONV SV** Perl_avhv_fetch_ent(pTHX_ AV *ar, SV* keysv, I32 lval, U32 hash);
STATIC void S_cv_dump(pTHX_ CV *cv);
STATIC CV* S_cv_clone2(pTHX_ CV *proto, CV *outside);
STATIC bool S_scalar_mod_type(pTHX_ OP *o, I32 type);
+STATIC OP * S_method_2entersub(pTHX_ OP *o, OP *o2, OP *svop);
STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs);
STATIC OP * S_dup_attrlist(pTHX_ OP *o);
STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs);
STATIC char* S_scan_trans(pTHX_ char *start);
STATIC char* S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp);
STATIC char* S_skipspace(pTHX_ char *s);
+STATIC char* S_swallow_bom(pTHX_ char *s);
STATIC void S_checkcomma(pTHX_ char *s, char *name, char *what);
STATIC void S_force_ident(pTHX_ char *s, int kind);
STATIC void S_incline(pTHX_ char *s);
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib';
+ require Config; import Config;
+ if (($Config{'extensions'} !~ /\b(DB|[A-Z]DBM)_File\b/) ){
+ print "1..0 # Skipping (no DB_File or [A-Z]DBM_File)\n";
+ exit 0;
+ }
}
require AnyDBM_File;
use Fcntl;
BEGIN {
chdir( 't' ) if -d 't';
unshift @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){
+ print "1..0 # Skip: Devel::DProf was not built\n";
+ exit 0;
+ }
}
END {
use Benchmark qw( timediff timestr );
use Getopt::Std 'getopts';
-use Config '%Config';
getopts('vI:p:');
# -v Verbose
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib' if -d '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+ print "1..0 # Skip: Data::Dumper was not built\n";
+ exit 0;
+ }
}
use Data::Dumper;
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib' if -d '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
+ print "1..0 # Skip: Data::Dumper was not built\n";
+ exit 0;
+ }
}
use Data::Dumper;
BEGIN {
chdir 't' if -d 't';
unshift @INC, '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bSys\/Hostname\b/) {
+ print "1..0 # Skip: Sys::Hostname was not built\n";
+ exit 0;
+ }
}
use Sys::Hostname;
my $reason;
- if ($Config{'d_sem'} ne 'define') {
+ if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
+ $reason = 'IPC::SysV was not built';
+ } elsif ($Config{'d_sem'} ne 'define') {
$reason = '$Config{d_sem} undefined';
} elsif ($Config{'d_msg'} ne 'define') {
$reason = '$Config{d_msg} undefined';
#!./perl
-# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $
+# Tests sprintf, excluding handling of 64-bit integers or long
+# doubles (if supported), of machine-specific short and long
+# integers, machine-specific floating point exceptions (infinity,
+# not-a-number ...), of the effects of locale, and of features
+# specific to multi-byte characters (under use utf8 and such).
BEGIN {
chdir 't' if -d 't';
}
use warnings;
-print "1..4\n";
+while (<DATA>) {
+ s/^\s*>//; s/<\s*$//;
+ push @tests, [split(/<\s*>/, $_, 4)];
+}
+
+print '1..', scalar @tests, "\n";
$SIG{__WARN__} = sub {
if ($_[0] =~ /^Invalid conversion/) {
- $w++;
+ $w = ' INVALID'
} else {
- warn @_;
+ warn @_;
}
};
-$w = 0;
-$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b %x %X %#b %#x %#X","hi",123,0,456,0,ord('A'),3.0999,11,171,171,11,171,171);
-if ($x eq ' hi 123 %foo 456 0A3.1 1011 ab AB 0b1011 0xab 0XAB' && $w == 0) {
- print "ok 1\n";
-} else {
- print "not ok 1 '$x'\n";
-}
-
-for $i (2 .. 4) {
- $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2];
- $w = 0;
- $x = sprintf($f, '');
- if ($x eq $f && $w == 1) {
- print "ok $i\n";
- } else {
- print "not ok $i '$x' '$f' '$w'\n";
+for ($i = 1; @tests; $i++) {
+ ($template, $data, $result, $comment) = @{shift @tests};
+ $evalData = eval $data;
+ $w = undef;
+ $x = sprintf(">$template<",
+ defined @$evalData ? @$evalData : $evalData);
+ substr($x, -1, 0) = $w if $w;
+ if ($x eq ">$result<") {
+ print "ok $i\n";
+ }
+ else {
+ print("not ok $i >$template< >$data< >$result< $x",
+ $comment ? " # $comment\n" : "\n");
}
}
+
+# In each of the the following lines, there are three required fields:
+# printf template, data to be formatted (as a Perl expression), and
+# expected result of formatting. An optional fourth field can contain
+# a comment. Each field is delimited by a starting '>' and a
+# finishing '<'; any whitespace outside these start and end marks is
+# not part of the field. If formatting requires more than one data
+# item (for example, if variable field widths are used), the Perl data
+# expression should return a reference to an array having the requisite
+# number of elements. Even so, subterfuge is sometimes required: see
+# tests for %n and %p.
+#
+# template data result
+__END__
+>%6 .6s< >''< >%6 .6s INVALID< >First test from old sprintf.t<
+>%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)<
+>%6.6 s< >''< >%6.6 s INVALID<
+>%3s< >'hi'< > hi<
+>%-4s< >123< >123 <
+>%%foo< >'bar'< >%foo<
+>%.0d< >0< ><
+>%5d< >456< > 456<
+>%#x< >0< >0<
+>%c< >ord('A')< >A<
+>%3.1f< >3.0999< >3.1<
+>%b< >11< >1011<
+>%x< >171< >ab<
+>%X< >171< >AB<
+>%#b< >11< >0b1011<
+>%#x< >171< >0xab<
+>%#X< >171< >0XAB< >Last test from old sprintf.t<
+>%A< >''< >%A INVALID< >First new test<
+>%B< >''< >%B INVALID<
+>%C< >''< >%C INVALID<
+>%D< >0x7fffffff< >2147483647< >Synonym for %ld<
+>%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"<
+>%F< >123456.789< >123456.789000< >Synonym for %f<
+>%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"<
+>%G< >12345.6789< >12345.7<
+>%H< >''< >%H INVALID<
+>%I< >''< >%I INVALID<
+>%J< >''< >%J INVALID<
+>%K< >''< >%K INVALID<
+>%L< >''< >%L INVALID<
+>%M< >''< >%M INVALID<
+>%N< >''< >%N INVALID<
+>%O< >2**32-1< >37777777777< >Synonym for %lo<
+>%P< >''< >%P INVALID<
+>%Q< >''< >%Q INVALID<
+>%R< >''< >%R INVALID<
+>%S< >''< >%S INVALID<
+>%T< >''< >%T INVALID<
+>%U< >2**32-1< >4294967295< >Synonym for %lu<
+>%V< >''< >%V INVALID<
+>%W< >''< >%W INVALID<
+>%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters<
+>%#X< >2**32-1< >0XFFFFFFFF<
+>%Y< >''< >%Y INVALID<
+>%Z< >''< >%Z INVALID<
+>%a< >''< >%a INVALID<
+>%b< >2**32-1< >11111111111111111111111111111111<
+>%+b< >2**32-1< >11111111111111111111111111111111<
+>%#b< >2**32-1< >0b11111111111111111111111111111111<
+>%34b< >2**32-1< > 11111111111111111111111111111111<
+>%034b< >2**32-1< >0011111111111111111111111111111111<
+>%-34b< >2**32-1< >11111111111111111111111111111111 <
+>%-034b< >2**32-1< >11111111111111111111111111111111 <
+>%c< >ord('A')< >A<
+>%10c< >ord('A')< > A<
+>%#10c< >ord('A')< > A< ># modifier: no effect<
+>%010c< >ord('A')< >000000000A<
+>%10lc< >ord('A')< > A< >l modifier: no effect<
+>%10hc< >ord('A')< > A< >h modifier: no effect<
+>%10.5c< >ord('A')< > A< >precision: no effect<
+>%-10c< >ord('A')< >A <
+>%d< >123456.789< >123456<
+>%d< >-123456.789< >-123456<
+>%d< >0< >0<
+>%+d< >0< >+0<
+>%0d< >0< >0<
+>%.0d< >0< ><
+>%+.0d< >0< >+<
+>%.0d< >1< >1<
+>%d< >1< >1<
+>%+d< >1< >+1<
+>%#3.2d< >1< > 01< ># modifier: no effect<
+>%3.2d< >1< > 01<
+>%03.2d< >1< >001<
+>%-3.2d< >1< >01 <
+>%-03.2d< >1< >01 < >zero pad + left just.: no effect<
+>%d< >-1< >-1<
+>%+d< >-1< >-1<
+>%hd< >1< >1< >More extensive testing of<
+>%ld< >1< >1< >length modifiers would be<
+>%Vd< >1< >1< >platform-specific<
+>%vd< >chr(1)< >1<
+>%+vd< >chr(1)< >+1<
+>%#vd< >chr(1)< >1<
+>%vd< >"\01\02\03"< >1.2.3<
+>%v.3d< >"\01\02\03"< >001.002.003<
+>%v03d< >"\01\02\03"< >001.002.003<
+>%v-3d< >"\01\02\03"< >1 .2 .3 <
+>%v+-3d< >"\01\02\03"< >+1 .2 .3 <
+>%v4.3d< >"\01\02\03"< > 001. 002. 003<
+>%v04.3d< >"\01\02\03"< >0001.0002.0003<
+>%*v02d< >['-', "\0\6\35"]< >00-06-29<
+>%e< >1234.875< >1.234875e+03<
+>%+e< >1234.875< >+1.234875e+03<
+>%#e< >1234.875< >1.234875e+03<
+>%e< >-1234.875< >-1.234875e+03<
+>%+e< >-1234.875< >-1.234875e+03<
+>%#e< >-1234.875< >-1.234875e+03<
+>%.0e< >1234.875< >1e+03<
+>%.*e< >[0, 1234.875]< >1e+03<
+>%.1e< >1234.875< >1.2e+03<
+>%-12.4e< >1234.875< >1.2349e+03 <
+>%12.4e< >1234.875< > 1.2349e+03<
+>%+-12.4e< >1234.875< >+1.2349e+03 <
+>%+12.4e< >1234.875< > +1.2349e+03<
+>%+-12.4e< >-1234.875< >-1.2349e+03 <
+>%+12.4e< >-1234.875< > -1.2349e+03<
+>%f< >1234.875< >1234.875000<
+>%+f< >1234.875< >+1234.875000<
+>%#f< >1234.875< >1234.875000<
+>%f< >-1234.875< >-1234.875000<
+>%+f< >-1234.875< >-1234.875000<
+>%#f< >-1234.875< >-1234.875000<
+>%6f< >1234.875< >1234.875000<
+>%*f< >[6, 1234.875]< >1234.875000<
+>%.0f< >1234.875< >1235<
+>%.1f< >1234.875< >1234.9<
+>%-8.1f< >1234.875< >1234.9 <
+>%8.1f< >1234.875< > 1234.9<
+>%+-8.1f< >1234.875< >+1234.9 <
+>%+8.1f< >1234.875< > +1234.9<
+>%+-8.1f< >-1234.875< >-1234.9 <
+>%+8.1f< >-1234.875< > -1234.9<
+>%*.*f< >[5, 2, 12.3456]< >12.35<
+>%g< >12345.6789< >12345.7<
+>%+g< >12345.6789< >+12345.7<
+>%#g< >12345.6789< >12345.7<
+>%.0g< >12345.6789< >1e+04<
+>%.2g< >12345.6789< >1.2e+04<
+>%.*g< >[2, 12345.6789]< >1.2e+04<
+>%.9g< >12345.6789< >12345.6789<
+>%12.9g< >12345.6789< > 12345.6789<
+>%012.9g< >12345.6789< >0012345.6789<
+>%-12.9g< >12345.6789< >12345.6789 <
+>%*.*g< >[-12, 9, 12345.6789]< >12345.6789 <
+>%-012.9g< >12345.6789< >12345.6789 <
+>%g< >-12345.6789< >-12345.7<
+>%+g< >-12345.6789< >-12345.7<
+>%g< >1234567.89< >1.23457e+06<
+>%+g< >1234567.89< >+1.23457e+06<
+>%#g< >1234567.89< >1.23457e+06<
+>%g< >-1234567.89< >-1.23457e+06<
+>%+g< >-1234567.89< >-1.23457e+06<
+>%#g< >-1234567.89< >-1.23457e+06<
+>%13g< >1234567.89< > 1.23457e+06<
+>%+13g< >1234567.89< > +1.23457e+06<
+>%013g< >1234567.89< >001.23457e+06<
+>%-13g< >1234567.89< >1.23457e+06 <
+>%h< >''< >%h INVALID<
+>%i< >123456.789< >123456< >Synonym for %d<
+>%j< >''< >%j INVALID<
+>%k< >''< >%k INVALID<
+>%l< >''< >%l INVALID<
+>%m< >''< >%m INVALID<
+>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n<
+>%o< >2**32-1< >37777777777<
+>%+o< >2**32-1< >37777777777<
+>%#o< >2**32-1< >037777777777<
+>%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?<
+>%q< >''< >%q INVALID<
+>%r< >''< >%r INVALID<
+>%s< >'string'< >string<
+>%10s< >'string'< > string<
+>%+10s< >'string'< > string<
+>%#10s< >'string'< > string<
+>%010s< >'string'< >0000string<
+>%0*s< >[10, 'string']< >0000string<
+>%-10s< >'string'< >string <
+>%3s< >'string'< >string<
+>%.3s< >'string'< >str<
+>%.*s< >[3, 'string']< >str<
+>%t< >''< >%t INVALID<
+>%u< >2**32-1< >4294967295<
+>%+u< >2**32-1< >4294967295<
+>%#u< >2**32-1< >4294967295<
+>%12u< >2**32-1< > 4294967295<
+>%012u< >2**32-1< >004294967295<
+>%-12u< >2**32-1< >4294967295 <
+>%-012u< >2**32-1< >4294967295 <
+>%v< >''< >%v INVALID<
+>%w< >''< >%w INVALID<
+>%x< >2**32-1< >ffffffff<
+>%+x< >2**32-1< >ffffffff<
+>%#x< >2**32-1< >0xffffffff<
+>%10x< >2**32-1< > ffffffff<
+>%010x< >2**32-1< >00ffffffff<
+>%-10x< >2**32-1< >ffffffff <
+>%-010x< >2**32-1< >ffffffff <
+>%0-10x< >2**32-1< >ffffffff <
+>%0*x< >[-10, ,2**32-1]< >ffffffff <
+>%y< >''< >%y INVALID<
+>%z< >''< >%z INVALID<
$ENV{PATH} = $ENV{PATH};
$ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy';
}
- if ($Config{d_shm} || $Config{d_msg}) {
+ if ($Config{'extensions'} =~ /\bIPC\/SysV\b/
+ && ($Config{d_shm} || $Config{d_msg})) {
require IPC::SysV;
IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU));
}
# test shmread
{
- if ($Config{d_shm}) {
+ if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) {
no strict 'subs';
my $sent = "foobar";
my $rcvd;
# test msgrcv
{
- if ($Config{d_msg}) {
+ if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) {
no strict 'subs';
my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
-$origdir = cwd;
+my $origdir = cwd;
chdir dirname($0);
-$file = basename($0, '.PL');
+my $file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
=head1 SYNOPSIS
-B<h2xs> [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]]
+B<h2xs> [B<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [headerfile ... [extra_libraries]]
B<h2xs> B<-h>
Omits creation of the F<Changes> file, and adds a HISTORY section to
the POD template.
-=item B<-F>
+=item B<-F> I<addflags>
Additional flags to specify to C preprocessor when scanning header for
function declarations. Should not be used without B<-x>.
pointer (like C<long long>), pointers to functions, or arrays. See
also the section on L<LIMITATIONS of B<-x>>.
+=item B<-b> I<version>
+
+Generates a .pm file which is backwards compatible with the specified
+perl version.
+
+For versions < 5.6.0, the changes are.
+ - no use of 'our' (uses 'use vars' instead)
+ - no 'use warnings'
+
+Specifying a compatibility version higher than the version of perl you
+are using to run h2xs will have no effect.
+
=back
=head1 EXAMPLES
my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
my $TEMPLATE_VERSION = '0.01';
my @ARGS = @ARGV;
+my $compat_version = $];
use Getopt::Std;
sub usage{
warn "@_\n" if @_;
- die "h2xs [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
+ die "h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [headerfile [extra_libraries]]
version: $H2XS_VERSION
-A Omit all autoloading facilities (implies -c).
-C Omit creating the Changes file, add HISTORY heading to stub POD.
-s Create subroutines for specified macros.
-v Specify a version number for this extension.
-x Autogenerate XSUBs using C::Scan.
+ -b Specify a perl version to be backwards compatibile with
extra_libraries
are any libraries that might be needed for loading the
extension, e.g. -lm would try to link in the math library.
}
-getopts("ACF:M:OPXacdfhkmn:o:p:s:v:x") || usage;
+getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:") || usage;
use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d
- $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
+ $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x
+ $opt_b);
usage if $opt_h;
+if( $opt_b ){
+ usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
+ $opt_b =~ /^\d+\.\d+\.\d+/ ||
+ usage "You must provide the backwards compatibility version in X.Y.Z form. " .
+ "(i.e. 5.5.0)\n";
+ my ($maj,$min,$sub) = split(/\./,$opt_b,3);
+ $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub);
+}
+
if( $opt_v ){
$TEMPLATE_VERSION = $opt_v;
}
$" = "\n\t";
warn "Writing $ext$modpname/$modfname.pm\n";
+if ( $compat_version < 5.006 ) {
+print PM <<"END";
+package $module;
+
+use $compat_version;
+use strict;
+END
+}
+else {
print PM <<"END";
package $module;
use strict;
use warnings;
END
+}
unless( $opt_X || $opt_c || $opt_A ){
# we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
}
}
+if ( $compat_version < 5.006 ) {
+ if ( $opt_X || $opt_c || $opt_A ) {
+ print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);';
+ } else {
+ print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);';
+ }
+}
+
# Determine @ISA.
my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this.
$myISA .= ' DynaLoader' unless $opt_X; # no XS
$myISA .= ');';
+$myISA =~ s/^our // if $compat_version < 5.006;
+
print PM "\n$myISA\n\n";
my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
-print PM<<"END";
+my $tmp=<<"END";
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
END
+$tmp =~ s/^our //mg if $compat_version < 5.006;
+print PM $tmp;
+
if (@vdecls) {
printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
}
+
+$tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" );
print PM <<"END" unless $opt_c or $opt_X;
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# to the AUTOLOAD in AutoLoader.
my \$constname;
- our \$AUTOLOAD;
+ $tmp
(\$constname = \$AUTOLOAD) =~ s/.*:://;
croak "&$module::constant not defined" if \$constname eq 'constant';
my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
$DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
$DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
$DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
-#ifdef USE_THREADS
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
static perl_mutex primenv_mutex;
MUTEX_INIT(&primenv_mutex);
#endif
projects / platform / upstream / perl.git / commitdiff