diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 0b1ced7ae1..11c580aa5f 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,8 @@ priorities and future plans. ## Work in progress +- Fix bundled IO, nested launcher, locale, and core user/group database module compatibility. + - Snapshot mutable array entries while marking package roots and during reachability walks so concurrent thread teardown cannot fail with `ConcurrentModificationException`. - Enforce restricted-hash key access and implement `Hash::Util` key, value, and hash locking (#1502, #1172). diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index 104685ba30..ebe363a979 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -578,9 +578,29 @@ private static List expandResolvedCommandForProcessBuilder( if (SystemUtils.osIsWindows()) { return expandWindowsBatchForProcessBuilder(commandArgs, currentDirectory); } + // Resolve an explicit nested $^X invocation in this JVM. Starting + // the shell launcher again would make Java discovery depend on the + // child's (possibly deliberately cleaned) PATH and environment. + if (isCurrentJperlExecutable(commandArgs.getFirst(), currentDirectory)) { + List direct = new ArrayList<>(ForkOpenState.currentJavaCommand()); + direct.addAll(commandArgs.subList(1, commandArgs.size())); + return direct; + } return expandJperlShebangForProcessBuilder(commandArgs); } + private static boolean isCurrentJperlExecutable(String command, File currentDirectory) { + String current = getCurrentJperlPath(); + if (current == null || current.isEmpty()) return false; + File candidate = new File(command); + if (!candidate.isAbsolute()) candidate = new File(currentDirectory, command); + try { + return candidate.getCanonicalFile().equals(new File(current).getCanonicalFile()); + } catch (IOException e) { + return candidate.getAbsolutePath().equals(new File(current).getAbsolutePath()); + } + } + private static boolean isExecutableCandidate(File candidate, String candidateName) { if (!candidate.isFile()) { return false; diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java b/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java index 82f9e2a712..cb70baa085 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Encode.java @@ -225,6 +225,11 @@ public static void initialize() { encode.registerMethod("resolve_alias", null); encode.registerMethod("perlio_ok", null); encode.registerMethod("find_mime_encoding", null); + // Perl 5.42+ Encode.pm calls this XS bootstrap callback after + // XSLoader::load. Its BOOT work is already performed by this + // Java initializer, but the callback must exist before the Perl + // source reaches the strict-subs checked `onBOOT;` call. + encode.registerMethod("onBOOT", null); } catch (NoSuchMethodException e) { System.err.println("Warning: Missing Encode method: " + e.getMessage()); } @@ -260,6 +265,11 @@ public static void initialize() { } } + /** Encode.pm's XS BOOT initialization is completed by {@link #initialize()}. */ + public static RuntimeList onBOOT(RuntimeArray args, int ctx) { + return new RuntimeList(); + } + // --- Constant accessor methods --- public static RuntimeList FB_DEFAULT(RuntimeArray args, int ctx) { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/I18NLanginfo.java b/src/main/java/org/perlonjava/runtime/perlmodule/I18NLanginfo.java index bd3085cf7c..72ad6bf23c 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/I18NLanginfo.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/I18NLanginfo.java @@ -190,7 +190,14 @@ public static RuntimeList langinfo(RuntimeArray args, int ctx) { item = args.get(0).getInt(); } - Locale locale = Locale.getDefault(); + String timeLocale = org.perlonjava.runtime.runtimetypes.PerlRuntime.current() + .regexState().localeState.currentTime(); + String languageTag = timeLocale.trim().replace('_', '-').replaceFirst("\\..*$", "") + .replaceFirst("@.*$", ""); + Locale locale = "C".equalsIgnoreCase(languageTag) + || "POSIX".equalsIgnoreCase(languageTag) + ? Locale.US : Locale.forLanguageTag(languageTag); + if (locale.getLanguage().isEmpty()) locale = Locale.US; DateFormatSymbols dateSymbols = DateFormatSymbols.getInstance(locale); DecimalFormatSymbols decimalSymbols = DecimalFormatSymbols.getInstance(locale); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java b/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java index 804be97f08..d10493a1cc 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java @@ -517,15 +517,18 @@ public static RuntimeList setlocale(RuntimeArray args, int ctx) { int category = args.isEmpty() ? 0 : args.get(0).getInt(); RuntimeLocaleState localeState = PerlRuntime.current().regexState().localeState; if (args.size() < 2) { - return new RuntimeScalar(localeState.currentCtype()).getList(); + String current = switch (category) { + case 0 -> localeState.currentCtype(); + case 5 -> localeState.currentTime(); + default -> localeState.currentCtype(); + }; + return new RuntimeScalar(current).getList(); } String requested = args.get(1).toString(); if (!isSupportedLocale(requested)) return RuntimeScalarCache.scalarUndef.getList(); - // LC_ALL (0) publication includes LC_CTYPE. The remaining categories - // have no regex effect, but return the same validated locale as POSIX. - if (category == 0 || category == 2) { - return new RuntimeScalar(localeState.publishCtype(requested)).getList(); - } + if (category == 0) return new RuntimeScalar(localeState.publishAll(requested)).getList(); + if (category == 2) return new RuntimeScalar(localeState.publishCtype(requested)).getList(); + if (category == 5) return new RuntimeScalar(localeState.publishTime(requested)).getList(); return new RuntimeScalar(requested).getList(); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeLocaleState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeLocaleState.java index 2261d08db3..b36944a588 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeLocaleState.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeLocaleState.java @@ -4,7 +4,7 @@ import java.util.Objects; /** - * Per-runtime LC_CTYPE publication state. + * Per-runtime locale publication state. * *

This is deliberately independent of {@link Locale#setDefault(Locale)}: * changing Perl's locale must neither mutate the JVM process default nor leak @@ -15,18 +15,23 @@ */ public final class RuntimeLocaleState { private String ctypeName = environmentCtype(); + private String timeName = environmentTime(); private long generation; - public record Snapshot(String ctypeName, long generation) {} + public record Snapshot(String ctypeName, String timeName, long generation) {} public synchronized Snapshot snapshot() { - return new Snapshot(ctypeName, generation); + return new Snapshot(ctypeName, timeName, generation); } public synchronized String currentCtype() { return ctypeName; } + public synchronized String currentTime() { + return timeName; + } + /** Publishes an already-validated LC_CTYPE name and returns it. */ public synchronized String publishCtype(String localeName) { String normalized = normalize(localeName); @@ -37,9 +42,24 @@ public synchronized String publishCtype(String localeName) { return ctypeName; } + /** Publishes an already-validated LC_TIME name and returns it. */ + public synchronized String publishTime(String localeName) { + timeName = normalize(localeName); + return timeName; + } + + /** LC_ALL updates the categories represented by this runtime state. */ + public synchronized String publishAll(String localeName) { + String normalized = normalize(localeName); + publishCtype(normalized); + publishTime(normalized); + return normalized; + } + void snapshotInto(RuntimeLocaleState target) { Snapshot snapshot = snapshot(); target.ctypeName = snapshot.ctypeName; + target.timeName = snapshot.timeName; target.generation = snapshot.generation; } @@ -55,4 +75,12 @@ private static String environmentCtype() { } return "C"; } + + private static String environmentTime() { + for (String variable : new String[] { "LC_ALL", "LC_TIME", "LANG" }) { + String value = System.getenv(variable); + if (value != null && !value.isBlank()) return value.trim(); + } + return "C"; + } } diff --git a/src/main/perl/lib/Config.pm b/src/main/perl/lib/Config.pm index da967435a3..97f0b9717a 100644 --- a/src/main/perl/lib/Config.pm +++ b/src/main/perl/lib/Config.pm @@ -207,6 +207,18 @@ my $startperl = $is_windows d_fchdir => 'define', d_fchmod => 'define', + # User::pwent uses these Configure probes to expose only fields supported + # by the active passwd structure. PerlOnJava's FFM adapter provides the + # portable passwd fields and does not expose platform-specific extensions. + d_pwage => undef, + d_pwchange => undef, + d_pwclass => undef, + d_pwcomment => undef, + d_pwexpire => undef, + d_pwgecos => 'define', + d_pwpasswd => 'define', + d_pwquota => undef, + # PerlOnJava specific perlonjava => '5.44.1', java_version => $java_version, diff --git a/src/main/perl/lib/FileHandle.pm b/src/main/perl/lib/FileHandle.pm index b4b7d78b95..f281691827 100644 --- a/src/main/perl/lib/FileHandle.pm +++ b/src/main/perl/lib/FileHandle.pm @@ -51,6 +51,10 @@ sub pipe { # IO::Handle->import( grep { !defined(&$_) && $_ ne 'pipe' } @EXPORT, @EXPORT_OK ); +# FileHandle also aliases methods from IO::Seekable below. Load it directly +# here instead of relying on IO::File's transitive import ordering. +require IO::Seekable; + # # Some people call "FileHandle::function", so all the functions # that were in the old FileHandle class must be imported, too. diff --git a/src/main/perl/lib/User/grent.pm b/src/main/perl/lib/User/grent.pm new file mode 100644 index 0000000000..51e8d67647 --- /dev/null +++ b/src/main/perl/lib/User/grent.pm @@ -0,0 +1,87 @@ +package User::grent 1.05; +use v5.38; + +our ($gr_name, $gr_gid, $gr_passwd, @gr_members); + +use Exporter 'import'; +our @EXPORT = qw(getgrent getgrgid getgrnam getgr); +our @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd @gr_members); +our %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + +use Class::Struct qw(struct); +struct 'User::grent' => [ + name => '$', + passwd => '$', + gid => '$', + members => '@', +]; + +sub populate { + return unless @_; + my $gob = new(); + ($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2]; + @gr_members = @{$gob->[3]} = split ' ', $_[3]; + return $gob; +} + +sub getgrent :prototype( ) { populate(CORE::getgrent()) } +sub getgrnam :prototype($) { populate(CORE::getgrnam(shift)) } +sub getgrgid :prototype($) { populate(CORE::getgrgid(shift)) } +sub getgr :prototype($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam } + +__END__ + +=head1 NAME + +User::grent - by-name interface to Perl's built-in getgr*() functions + +=head1 SYNOPSIS + + use User::grent; + my $gr = getgrgid(0) or die "No group zero"; + if ( $gr->name eq 'wheel' && @{$gr->members} > 1 ) { + print "gid zero name wheel, with other members"; + } + + use User::grent qw(:FIELDS); + getgrgid(0) or die "No group zero"; + if ( $gr_name eq 'wheel' && @gr_members > 1 ) { + print "gid zero name wheel, with other members"; + } + + my $gr = getgr($whoever); + +=head1 DESCRIPTION + +This module's default exports override the core getgrent(), getgrgid(), +and getgrnam() functions, replacing them with versions that return +"User::grent" objects. This object has methods that return the similarly +named structure field name from the C's passwd structure from F; +namely name, passwd, gid, and members (not mem). The first three +return scalars, the last an array reference. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C. Thus, C<$group_obj-Egid()> corresponds +to $gr_gid if you import the fields. Array references are available as +regular array variables, so C<@{ $group_obj-Emembers() }> would be +simply @gr_members. + +The getgr() function is a simple front-end that forwards a numeric +argument to getgrgid() and the rest to getgrnam(). + +To access this functionality without the core overrides, +pass the C an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/src/main/perl/lib/User/pwent.pm b/src/main/perl/lib/User/pwent.pm new file mode 100644 index 0000000000..46e31d5501 --- /dev/null +++ b/src/main/perl/lib/User/pwent.pm @@ -0,0 +1,290 @@ +package User::pwent 1.03; +use v5.38; + +use Config; +use Carp; + +our ( $pw_name, $pw_passwd, $pw_uid, $pw_gid, + $pw_gecos, $pw_dir, $pw_shell, + $pw_expire, $pw_change, $pw_class, + $pw_age, + $pw_quota, $pw_comment, + ); + +use Exporter 'import'; +our @EXPORT = qw(getpwent getpwuid getpwnam getpw); +our @EXPORT_OK = qw( + pw_has + + $pw_name $pw_passwd $pw_uid $pw_gid + $pw_gecos $pw_dir $pw_shell + $pw_expire $pw_change $pw_class + $pw_age + $pw_quota $pw_comment + ); +our %EXPORT_TAGS = ( + FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ], + ALL => [ @EXPORT, @EXPORT_OK ], + ); + +# +# XXX: these mean somebody hacked this module's source +# without understanding the underlying assumptions. +# +my $IE = "[INTERNAL ERROR]"; + +use Class::Struct qw(struct); +struct 'User::pwent' => [ + name => '$', # pwent[0] + passwd => '$', # pwent[1] + uid => '$', # pwent[2] + gid => '$', # pwent[3] + + # you'll only have one/none of these three + change => '$', # pwent[4] + age => '$', # pwent[4] + quota => '$', # pwent[4] + + # you'll only have one/none of these two + comment => '$', # pwent[5] + class => '$', # pwent[5] + + # you might not have this one + gecos => '$', # pwent[6] + + dir => '$', # pwent[7] + shell => '$', # pwent[8] + + # you might not have this one + expire => '$', # pwent[9] + +]; + + +# init our groks hash to be true if the built platform knew how +# to do each struct pwd field that perl can ever under any circumstances +# know about. we do not use /^pw_?/, but just the tails. +sub _feature_init { + our %Groks; # whether build system knew how to do this feature + for my $feep ( qw{ + pwage pwchange pwclass pwcomment + pwexpire pwgecos pwpasswd pwquota + } + ) + { + my $short = $feep =~ /^pw(.*)/ + ? $1 + : do { + # not cluck, as we know we called ourselves, + # and a confession is probably imminent anyway + warn("$IE $feep is a funny struct pwd field"); + $feep; + }; + + exists $Config{ "d_" . $feep } + || confess("$IE Configure doesn't d_$feep"); + $Groks{$short} = defined $Config{ "d_" . $feep }; + } + # assume that any that are left are always there + for my $feep (grep /^\$pw_/s, @EXPORT_OK) { + $feep =~ /^\$pw_(.*)/; + $Groks{$1} = 1 unless defined $Groks{$1}; + } +} + +# With arguments, reports whether one or more fields are all implemented +# in the build machine's struct pwd pw_*. May be whitespace separated. +# We do not use /^pw_?/, just the tails. +# +# Without arguments, returns the list of fields implemented on build +# machine, space separated in scalar context. +# +# Takes exception to being asked whether this machine's struct pwd has +# a field that Perl never knows how to provide under any circumstances. +# If the module does this idiocy to itself, the explosion is noisier. +# +sub pw_has { + our %Groks; # whether build system knew how to do this feature + my $cando = 1; + my $sploder = caller() ne __PACKAGE__ + ? \&croak + : sub { confess("$IE @_") }; + if (@_ == 0) { + my @valid = sort grep { $Groks{$_} } keys %Groks; + return wantarray ? @valid : "@valid"; + } + for my $feep (map { split } @_) { + defined $Groks{$feep} + || $sploder->("$feep is never a valid struct pwd field"); + $cando &&= $Groks{$feep}; + } + return $cando; +} + +sub _populate { + return unless @_; + my $pwob = new(); + + # Any that haven't been pw_had are assumed on "all" platforms of + # course, this may not be so, but you can't get here otherwise, + # since the underlying core call already took exception to your + # impudence. + + $pw_name = $pwob->name ( $_[0] ); + $pw_passwd = $pwob->passwd ( $_[1] ) if pw_has("passwd"); + $pw_uid = $pwob->uid ( $_[2] ); + $pw_gid = $pwob->gid ( $_[3] ); + + if (pw_has("change")) { + $pw_change = $pwob->change ( $_[4] ); + } + elsif (pw_has("age")) { + $pw_age = $pwob->age ( $_[4] ); + } + elsif (pw_has("quota")) { + $pw_quota = $pwob->quota ( $_[4] ); + } + + if (pw_has("class")) { + $pw_class = $pwob->class ( $_[5] ); + } + elsif (pw_has("comment")) { + $pw_comment = $pwob->comment( $_[5] ); + } + + $pw_gecos = $pwob->gecos ( $_[6] ) if pw_has("gecos"); + + $pw_dir = $pwob->dir ( $_[7] ); + $pw_shell = $pwob->shell ( $_[8] ); + + $pw_expire = $pwob->expire ( $_[9] ) if pw_has("expire"); + + return $pwob; +} + +sub getpwent :prototype( ) { _populate(CORE::getpwent()) } +sub getpwnam :prototype($) { _populate(CORE::getpwnam(shift)) } +sub getpwuid :prototype($) { _populate(CORE::getpwuid(shift)) } +sub getpw :prototype($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam } + +_feature_init(); + +__END__ + +=head1 NAME + +User::pwent - by-name interface to Perl's built-in getpw*() functions + +=head1 SYNOPSIS + + use User::pwent; + my $pw = getpwnam('daemon') || die "No daemon user"; + if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) { + print "gid 1 on root dir"; + } + + my $real_shell = $pw->shell || '/bin/sh'; + + for (my ($fullname, $office, $workphone, $homephone) = + split /\s*,\s*/, $pw->gecos) + { + s/&/ucfirst(lc($pw->name))/ge; + } + + use User::pwent qw(:FIELDS); + getpwnam('daemon') || die "No daemon user"; + if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) { + print "gid 1 on root dir"; + } + + my $pw = getpw($whoever); + + use User::pwent qw/:DEFAULT pw_has/; + if (pw_has(qw[gecos expire quota])) { .... } + if (pw_has("name uid gid passwd")) { .... } + print "Your struct pwd has: ", scalar pw_has(), "\n"; + +=head1 DESCRIPTION + +This module's default exports override the core getpwent(), getpwuid(), +and getpwnam() functions, replacing them with versions that return +C objects. This object has methods that return the +similarly named structure field name from the C's passwd structure +from F, stripped of their leading "pw_" parts, namely C, +C, C, C, C, C, C, C, +C, C, C

, C, and C. The C, +C, and C fields are tainted when running in taint mode. + +You may also import all the structure fields directly into your +namespace as regular variables using the :FIELDS import tag. (Note +that this still overrides your core functions.) Access these fields +as variables named with a preceding C in front their method +names. Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell +if you import the fields. + +The getpw() function is a simple front-end that forwards +a numeric argument to getpwuid() and the rest to getpwnam(). + +To access this functionality without the core overrides, pass the +C an empty import list, and then access function functions +with their full qualified names. The built-ins are always still +available via the C pseudo-package. + +=head2 System Specifics + +Perl believes that no machine ever has more than one of C, +C, or C implemented, nor more than one of either +C or C. Some machines do not support C, +C, or allegedly, C. You may call these methods +no matter what machine you're on, but they return C if +unimplemented. + +You may ask whether one of these was implemented on the system Perl +was built on by asking the importable C function about them. +This function returns true if all parameters are supported fields +on the build platform, false if one or more were not, and raises +an exception if you asked about a field that Perl never knows how +to provide. Parameters may be in a space-separated string, or as +separate arguments. If you pass no parameters, the function returns +the list of C fields supported by your build platform's +C library, as a list in list context, or a space-separated string +in scalar context. Note that just because your C library had +a field doesn't necessarily mean that it's fully implemented on +that system. + +Interpretation of the C field varies between systems, but +traditionally holds 4 comma-separated fields containing the user's +full name, office location, work phone number, and home phone number. +An C<&> in the gecos field should be replaced by the user's properly +capitalized login C. The C field, if blank, must be +assumed to be F. Perl does not do this for you. The +C is one-way hashed garble, not clear text, and may not be +unhashed save by brute-force guessing. Secure systems use more a +more secure hashing than DES. On systems supporting shadow password +systems, Perl automatically returns the shadow password entry when +called by a suitably empowered user, even if your underlying +vendor-provided C library was too short-sighted to realize it should +do this. + +See passwd(5) and getpwent(3) for details. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen + +=head1 HISTORY + +=over 4 + +=item March 18th, 2000 + +Reworked internals to support better interface to dodgey fields +than normal Perl function provides. Added pw_has() field. Improved +documentation. + +=back diff --git a/src/test/resources/unit/custom_import_typeglob_strict.t b/src/test/resources/unit/custom_import_typeglob_strict.t new file mode 100644 index 0000000000..be7756f0cb --- /dev/null +++ b/src/test/resources/unit/custom_import_typeglob_strict.t @@ -0,0 +1,46 @@ +use strict; +use warnings; +use Test::More; + +package Local::SymbolicImporter::Hash; +sub TIEHASH { bless {}, shift } +sub FETCH { $_[1] eq 'imported' ? 42 : undef } +sub STORE { } +sub FIRSTKEY { 'imported' } +sub NEXTKEY { undef } +sub EXISTS { $_[1] eq 'imported' } +sub CLEAR { } + +package Local::SymbolicImporter; +our %provided_hash; +BEGIN { tie %provided_hash, 'Local::SymbolicImporter::Hash' } +sub provided_sub { 'imported sub' } +sub import { + my $pkg = shift; + my ($caller) = caller; + my @symbols = @_; + no strict 'refs'; + for my $symbol (@symbols) { + $symbol =~ s/^([\$\&\@\%])?//; + my $prefix = $1 || '&'; + my $imported = "${caller}::$symbol"; + my $source = "${pkg}::$symbol"; + if ($prefix eq '%') { + *{$imported} = \%{$source}; + } else { + *{$imported} = \&{$source}; + } + } +} + +package main; +BEGIN { Local::SymbolicImporter->import('%provided_hash', 'provided_sub') } + +is($provided_hash{imported}, 42, + 'a custom typeglob importer makes an imported hash visible under strict'); +is(ref(tied %provided_hash), 'Local::SymbolicImporter::Hash', + 'the custom importer preserves the tied hash alias'); +is(provided_sub(), 'imported sub', + 'a custom typeglob importer makes an imported sub visible under strict'); + +done_testing; diff --git a/src/test/resources/unit/encode_xsloader_onboot.t b/src/test/resources/unit/encode_xsloader_onboot.t new file mode 100644 index 0000000000..76e29099a1 --- /dev/null +++ b/src/test/resources/unit/encode_xsloader_onboot.t @@ -0,0 +1,15 @@ +use strict; +use warnings; +use Test::More; + +use Encode (); + +{ + package Encode; + onBOOT; +} + +ok(defined &Encode::onBOOT, + 'Java Encode registers the XSLoader onBOOT callback before strict compilation'); + +done_testing; diff --git a/src/test/resources/unit/io_seekable_getpos_load.t b/src/test/resources/unit/io_seekable_getpos_load.t new file mode 100644 index 0000000000..0e9b0a1aea --- /dev/null +++ b/src/test/resources/unit/io_seekable_getpos_load.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +use FileHandle; + +ok(defined &IO::Seekable::getpos, + 'IO::Seekable::getpos is available while FileHandle loads'); +ok(defined &FileHandle::getpos, 'FileHandle installs the getpos compatibility alias'); + +my $fh = FileHandle->new; +ok($fh, 'construct a FileHandle'); +ok($fh->open(__FILE__, '<'), 'open a seekable file'); +my $position = $fh->getpos; +ok(defined $position, 'getpos returns the current position'); +ok($fh->setpos($position), 'setpos restores the position'); +$fh->close; + +done_testing; diff --git a/src/test/resources/unit/jperl_nested_launch_clean_env.t b/src/test/resources/unit/jperl_nested_launch_clean_env.t new file mode 100644 index 0000000000..574cbb1bd5 --- /dev/null +++ b/src/test/resources/unit/jperl_nested_launch_clean_env.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +plan skip_all => 'nested launcher checks run only under PerlOnJava' + unless $ENV{PERLONJAVA_EXECUTABLE} && -x $ENV{PERLONJAVA_EXECUTABLE}; +plan skip_all => 'restricted PATH launcher check is Unix-only' if $^O eq 'MSWin32'; + +my $launcher = $^X; +my $status; +{ + # EnvDir -clean drops inherited launcher variables, then installs a PATH + # with no Java executable. A nested $^X must still start from this JVM. + local %ENV = (PATH => '/no-java-here'); + $status = system($launcher, '-e', 'exit 0'); +} + +is($status, 0, 'nested $^X starts after environment cleanup removes Java settings'); +done_testing; diff --git a/src/test/resources/unit/posix_langinfo_time_locale.t b/src/test/resources/unit/posix_langinfo_time_locale.t new file mode 100644 index 0000000000..8c6302b4a8 --- /dev/null +++ b/src/test/resources/unit/posix_langinfo_time_locale.t @@ -0,0 +1,16 @@ +use strict; +use warnings; +use Test::More; + +use POSIX qw(LC_TIME setlocale); +use I18N::Langinfo qw(langinfo MON_6 ABDAY_1); + +my $previous = setlocale(LC_TIME); +my $selected = setlocale(LC_TIME, 'fr_FR.UTF-8'); +plan skip_all => 'French locale is unavailable' unless defined $selected; + +is(langinfo(MON_6), 'juin', 'langinfo follows the selected LC_TIME month names'); +is(langinfo(ABDAY_1), 'dim.', 'langinfo follows the selected LC_TIME weekday names'); + +setlocale(LC_TIME, $previous) if defined $previous; +done_testing; diff --git a/src/test/resources/unit/user_pwent_grent_modules.t b/src/test/resources/unit/user_pwent_grent_modules.t new file mode 100644 index 0000000000..50b0a0fce9 --- /dev/null +++ b/src/test/resources/unit/user_pwent_grent_modules.t @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test::More; + +use User::pwent; +use User::grent; + +ok(User::pwent->can('getpwuid'), 'User::pwent loads and exports its interface'); +ok(User::grent->can('getgrgid'), 'User::grent loads and exports its interface'); + +my $pw = getpwuid($<); +ok($pw, 'getpwuid returns a User::pwent object'); +is($pw->uid, $<, 'User::pwent exposes the uid field'); + +my ($gid) = split /\s+/, $); +my $gr = getgrgid($gid); +ok($gr, 'getgrgid returns a User::grent object'); +is($gr->gid, $gid, 'User::grent exposes the gid field'); + +done_testing;