Version v5.7.2 Development release working toward v5.8
--------------
____________________________________________________________________________
+[ 14709] By: jhi on 2002/02/15 15:01:54
+ Log: Subject: [PATCH hints/solaris_2.sh]; was Re: [PATCH Configure] Interaction of cc.cbu and checkcc
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Thu, 14 Feb 2002 19:07:40 GMT
+ Message-Id: <200202141907.TAA21516@tempest.npl.co.uk>
+
+ (the hints part only)
+ Branch: perl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 14707] By: jhi on 2002/02/15 15:00:01
+ Log: Subject: Re: [PATCH hints/solaris_2.sh]; was Re: [PATCH Configure] Interaction of cc.cbu and checkcc
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Fri, 15 Feb 2002 12:14:39 GMT
+ Message-Id: <200202151214.MAA26466@tempest.npl.co.uk>
+
+ Split checking-for-gcc and checking-for-cc.
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 14706] By: ams on 2002/02/15 13:57:15
+ Log: Subject: Re: [ID 20020213.015] Pod::Html XHTML update for 5.7.2
+ From: Ville =?ISO-8859-1?Q?Skytt=E4?= <ville.skytta@iki.fi>
+ Date: 15 Feb 2002 10:53:06 +0200
+ Message-Id: <1013763186.28457.6.camel@cs78130147.pp.htv.fi>
+ Branch: perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 14705] By: ams on 2002/02/15 08:42:55
+ Log: Subject: [PATCH @14577] OS/2 tests and more
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Fri, 15 Feb 2002 03:56:24 -0500
+ Message-Id: <20020215035624.A16467@math.ohio-state.edu>
+ Branch: perl
+ + os2/OS2/Process/t/os2_process.t
+ + os2/OS2/Process/t/os2_process_kid.t
+ + os2/OS2/Process/t/os2_process_text.t
+ ! MANIFEST configpm hints/os2.sh makedef.pl
+ ! os2/OS2/Process/Makefile.PL os2/OS2/Process/Process.pm
+ ! os2/OS2/Process/Process.xs os2/os2.c os2/os2_base.t
+ ! os2/os2ish.h
+____________________________________________________________________________
+[ 14700] By: jhi on 2002/02/15 02:51:13
+ Log: Subject: [ID 20020213.015] Pod::Html XHTML update for 5.7.2
+ From: Ville "Skyttä" <ville.skytta@iki.fi>
+ Date: Wed, 13 Feb 2002 22:29:39 +0200
+ Message-Id: <20020213222939.5321b5ce.ville.skytta@iki.fi>
+ Branch: perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 14699] By: jhi on 2002/02/14 23:47:43
+ Log: Document and test the C0 and C1.
+ Branch: perl
+ ! lib/charnames.pm lib/charnames.t
+____________________________________________________________________________
+[ 14697] By: jhi on 2002/02/14 22:21:20
+ Log: Also OS/2 seems to need exe set early.
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 14696] By: jhi on 2002/02/14 22:13:18
+ Log: Document pack U0U.
+ Branch: perl
+ ! pod/perluniintro.pod
+____________________________________________________________________________
+[ 14695] By: jhi on 2002/02/14 21:56:52
+ Log: Subject: [PATCH] Re: bug? no warning from getc BOLLOCKS
+ From: Rafael Garcia-Suarez <rgarciasuarez@free.fr>
+ Date: Thu, 14 Feb 2002 23:58:00 +0100
+ Message-ID: <20020214235800.A12901@rafael>
+ Branch: perl
+ ! pp_sys.c t/lib/warnings/pp_sys
+____________________________________________________________________________
+[ 14694] By: jhi on 2002/02/14 21:54:43
+ Log: Subject: [PATCH @13746] conditional pragmas
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 31 Dec 2001 18:18:09 -0500
+ Message-ID: <20011231181809.A29528@math.ohio-state.edu>
+ Branch: perl
+ + lib/if.pm lib/if.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 14693] By: jhi on 2002/02/14 21:47:08
+ Log: Deparse bug introduced by #14615: the fix is just a workaround,
+ I suspect there to be another deeper bug, must distill simpler
+ test case.
+ Branch: perl
+ ! ext/B/B/Deparse.pm ext/B/t/deparse.t
+____________________________________________________________________________
+[ 14692] By: jhi on 2002/02/14 19:52:26
+ Log: Integrate perlio;
+
+ Make dependencies more precise (for nmake)
+ Branch: perl
+ !> ext/Encode/EUC_JP/Makefile.PL
+____________________________________________________________________________
+[ 14691] By: jhi on 2002/02/14 18:08:58
+ Log: Just a guess.
+ Branch: perl
+ ! lib/Tie/Handle.pm
+____________________________________________________________________________
+[ 14689] By: jhi on 2002/02/14 16:03:50
+ Log: Upgrade to Net::Ping 2.11.
+ Branch: perl
+ ! lib/Net/Ping.pm lib/Net/Ping/CHANGES lib/Net/Ping/README
+ ! lib/Net/Ping/t/110_icmp_inst.t lib/Net/Ping/t/120_udp_inst.t
+ ! lib/Net/Ping/t/130_tcp_inst.t lib/Net/Ping/t/140_stream_inst.t
+ ! lib/Net/Ping/t/200_ping_tcp.t lib/Net/Ping/t/300_ping_stream.t
+____________________________________________________________________________
+[ 14688] By: jhi on 2002/02/14 15:15:17
+ Log: Subject: [PATCH ExtUtils/Installed.pm ExtUtils/t/Installed.t]
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Wed, 13 Feb 2002 17:37:07 GMT
+ Message-Id: <200202131737.RAA29010@tempest.npl.co.uk>
+
+ (updated version of the above)
+ Branch: perl
+ ! lib/ExtUtils/Installed.pm lib/ExtUtils/t/Installed.t
+____________________________________________________________________________
+[ 14687] By: jhi on 2002/02/14 14:44:02
+ Log: Excise inexact blather.
+ Branch: perl
+ ! utf8.c
+____________________________________________________________________________
+[ 14686] By: jhi on 2002/02/14 14:30:35
+ Log: Subject: Re: [PATCH @13746] tied hashes: memoization
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 31 Dec 2001 20:28:46 -0500
+ Message-ID: <20011231202845.A1323@math.ohio-state.edu>
+ Branch: perl
+ + lib/Tie/Memoize.pm lib/Tie/Memoize.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 14684] By: jhi on 2002/02/14 14:09:10
+ Log: Subject: [PATCH @13746] tied hashes
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 31 Dec 2001 19:15:39 -0500
+ Message-ID: <20011231191539.A46@math.ohio-state.edu>
+ Branch: perl
+ ! lib/Tie/Hash.pm pod/perltie.pod
+____________________________________________________________________________
+[ 14683] By: jhi on 2002/02/13 22:30:55
+ Log: Subject: Re: [PATCH] Configure followed by make minitest
+ From: sthoenna@efn.org (Yitzchak Scott-Thoennes)
+ Date: Sun, 10 Feb 2002 23:22:05 -0800
+ Message-ID: <dE3Z8gzkgyBD092yn@efn.org>
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 14682] By: jhi on 2002/02/13 15:50:37
+ Log: Subject: Re: perl@14647
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Mon, 11 Feb 2002 19:30:36 +0100
+ Message-Id: <20020211192820.C199.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! t/op/groups.t
+____________________________________________________________________________
+[ 14681] By: jhi on 2002/02/13 15:14:25
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
[ 14680] By: jhi on 2002/02/13 13:41:50
Log: Integrate perlio;
# $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
#
-# Generated on Fri Feb 15 01:22:14 EET 2002 [metaconfig 3.0 PL70]
+# Generated on Sat Feb 16 18:18:46 EET 2002 [metaconfig 3.0 PL70]
# (with additional metaconfig patches by perlbug@perl.org)
cat >c1$$ <<EOF
;;
esac
-cat <<EOS >checkcc
+cat <<EOS >trygcc
$startsh
EOS
-cat <<'EOSC' >>checkcc
+cat <<'EOSC' >>trygcc
case "$cc" in
'') ;;
*) $rm -f try try.*
esac
fi
fi
+ fi
+ $rm -f try try.*
+ ;;
+esac
+EOSC
+
+cat <<EOS >checkcc
+$startsh
+EOS
+cat <<'EOSC' >>checkcc
+case "$cc" in
+'') ;;
+*) $rm -f try try.*
+ $cat >try.c <<EOM
+int main(int argc, char *argv[]) {
+ return 0;
+}
+EOM
+ if $cc -o try $ccflags $ldflags try.c; then
+ :
+ else
if $test X"$despair" = Xyes; then
- $cat >&4 <<EOM
+ echo "Uh-oh, the C compiler '$cc' doesn't seem to be working." >&4
+ fi
+ $cat >&4 <<EOM
You need to find a working C compiler.
Either (purchase and) install the C compiler supplied by your OS vendor,
or for a free C compiler try http://gcc.gnu.org/
I cannot continue any further, aborting.
EOM
- exit 1
- fi
+ exit 1
fi
$rm -f try try.*
;;
rp="Use which C compiler?"
. ./myread
cc="$ans"
+
+: See if they have not cc but they do have gcc
+. ./trygcc
: Look for a hint-file generated 'call-back-unit'. Now that the
: user has specified the compiler, we may need to set or change some
: other defaults.
eval $inlibc
: Check how to convert floats to strings.
+
+if test "X$d_Gconvert" = X; then
+
echo " "
echo "Checking for an efficient way to convert floats to strings."
echo " " > try.c
#define DOUBLETYPE long double
#endif
#ifdef TRY_sprintf
-#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && defined(HAS_PRIgldbl)
+#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+#ifdef HAS_PRIgldbl
#define Gconvert(x,n,t,b) sprintf((b),"%.*"$sPRIgldbl,(n),(x))
#else
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(double)(x))
+#endif
+#else
#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
#endif
char *myname = "sprintf";
Gconvert((DOUBLETYPE)0.1, 8, 0, buf);
checkit("0.1", buf);
+ Gconvert((DOUBLETYPE)0.01, 8, 0, buf);
+ checkit("0.01", buf);
+
+ Gconvert((DOUBLETYPE)0.001, 8, 0, buf);
+ checkit("0.001", buf);
+
+ Gconvert((DOUBLETYPE)0.0001, 8, 0, buf);
+ checkit("0.0001", buf);
+
+ Gconvert((DOUBLETYPE)0.00009, 8, 0, buf);
+ if (strlen(buf) > 5)
+ checkit("9e-005", buf); /* for Microsoft ?? */
+ else
+ checkit("9e-05", buf);
+
Gconvert((DOUBLETYPE)1.0, 8, 0, buf);
checkit("1", buf);
Gconvert((DOUBLETYPE)123.456, 8, 0, buf);
checkit("123.456", buf);
- /* Testing of 1e+129 in bigintpm.t must not get extra '.' here. */
- Gconvert((DOUBLETYPE)1e30, 8, 0, buf);
- if (strlen(buf) > 5)
- checkit("1e+030", buf); /* for Microsoft */
- else
- checkit("1e+30", buf);
+ /* Testing of 1e+129 in bigintpm.t must not get extra '.' here. */
+ Gconvert((DOUBLETYPE)1e30, 8, 0, buf);
+ if (strlen(buf) > 5)
+ checkit("1e+030", buf); /* for Microsoft */
+ else
+ checkit("1e+30", buf);
exit(0);
}
EOP
-case "$d_Gconvert" in
-gconvert*) xxx_list='gconvert gcvt sprintf' ;;
-gcvt*) xxx_list='gcvt gconvert sprintf' ;;
-sprintf*) xxx_list='sprintf gconvert gcvt' ;;
-*) xxx_list='gconvert gcvt sprintf' ;;
-esac
-
-case "$d_longdbl$uselongdouble$d_PRIgldbl" in
-"$define$define$define")
- # for long doubles prefer first qgcvt, then sprintf
- xxx_list="`echo $xxx_list|sed s/sprintf//`"
- xxx_list="sprintf $xxx_list"
- case "$d_qgcvt" in
- "$define") xxx_list="qgcvt $xxx_list" ;;
- esac
+: first add preferred functions to our list
+xxx_list=""
+for xxx_convert in $gconvert_preference; do
+ case $xxx_convert in
+ gcvt|gconvert|sprintf) xxx_list="$xxx_list $xxx_convert" ;;
+ *) echo "Discarding unrecognized gconvert_preference $xxx_convert" >&4 ;;
+ esac
+done
+: then add any others
+for xxx_convert in gconvert gcvt sprintf; do
+ case "$xxx_list" in
+ *$xxx_convert*) ;;
+ *) xxx_list="$xxx_list $xxx_convert" ;;
+ esac
+done
+
+case "$d_longdbl$uselongdouble" in
+"$define$define")
+ : again, add prefered functions to our list first
+ xxx_ld_list=""
+ for xxx_convert in $gconvert_ld_preference; do
+ case $xxx_convert in
+ qgcvt|gcvt|gconvert|sprintf) xxx_ld_list="$xxx_ld_list $xxx_convert" ;;
+ *) echo "Discarding unrecognized gconvert_ld_preference $xxx_convert" ;;
+ esac
+ done
+ : then add qgcvt, sprintf--then, in xxx_list order, gconvert and gcvt
+ for xxx_convert in qgcvt sprintf $xxx_list; do
+ case "$xxx_ld_list" in
+ $xxx_convert*|*" $xxx_convert"*) ;;
+ *) xxx_ld_list="$xxx_ld_list $xxx_convert" ;;
+ esac
+ done
+ : if sprintf cannot do long doubles, move it to the end
+ if test "$d_PRIgldbl" != "$define"; then
+ xxx_ld_list="`echo $xxx_ld_list|sed s/sprintf//` sprintf"
+ fi
+ : if no qgcvt, remove it
+ if test "$d_qgcvt" != "$define"; then
+ xxx_ld_list="`echo $xxx_ld_list|sed s/qgcvt//`"
+ fi
+ : use the ld_list
+ xxx_list="$xxx_ld_list"
;;
esac
break;
else
echo "...But $xxx_convert didn't work as I expected."
+ xxx_convert=''
fi
else
echo "$xxx_convert NOT found." >&4
fi
done
-
+
+if test X$xxx_convert = X; then
+ echo "*** WHOA THERE!!! ***" >&4
+ echo "None of ($xxx_list) seemed to work properly. I'll use sprintf." >&4
+ xxx_convert=sprintf
+fi
+
case "$xxx_convert" in
gconvert) d_Gconvert='gconvert((x),(n),(t),(b))' ;;
gcvt) d_Gconvert='gcvt((x),(n),(b))' ;;
*) case "$uselongdouble$d_longdbl$d_PRIgldbl" in
"$define$define$define")
d_Gconvert="sprintf((b),\"%.*\"$sPRIgldbl,(n),(x))" ;;
+ "$define$define$undef")
+ d_Gconvert='sprintf((b),"%.*g",(n),(double)(x))' ;;
*) d_Gconvert='sprintf((b),"%.*g",(n),(x))' ;;
esac
;;
esac
+fi
+
: see if _fwalk exists
set fwalk d__fwalk
eval $inlibc
ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer
ext/DynaLoader/README Dynamic Loader notes and intro
ext/DynaLoader/XSLoader_pm.PL Simple XS Loader perl module
+ext/Encode/CN/CN.pm Encode extension
+ext/Encode/CN/Makefile.PL Encode extension
ext/Encode/compile Encode extension
ext/Encode/encengine.c Encode extension
ext/Encode/encode.h Encode extension
ext/Encode/Encode/symbol.ucm Encode table
ext/Encode/Encode/viscii.enc Encode table
ext/Encode/Encode/viscii.ucm Encode table
-ext/Encode/EUC_JP/Japanese.pm Encode module for Japanese
-ext/Encode/EUC_JP/Makefile.PL Encode module for Japanese
+ext/Encode/JP/JP.pm Encode extension
+ext/Encode/JP/Makefile.PL Encode extension
+ext/Encode/KR/KR.pm Encode extension
+ext/Encode/KR/Makefile.PL Encode extension
ext/Encode/lib/Encode/Encoding.pm Encode extension
ext/Encode/lib/Encode/Internal.pm Encode extension
ext/Encode/lib/Encode/iso10646_1.pm Encode extension
+ext/Encode/lib/Encode/JP/Constants.pm Encode extension
+ext/Encode/lib/Encode/JP/H2Z.pm Encode extension
+ext/Encode/lib/Encode/JP/ISO_2022_JP.pm Encode extension
+ext/Encode/lib/Encode/JP/JIS.pm Encode extension
+ext/Encode/lib/Encode/JP/Tr.pm Encode extension
ext/Encode/lib/Encode/Tcl.pm Encode extension
ext/Encode/lib/Encode/Tcl/Escape.pm Encode extension
ext/Encode/lib/Encode/Tcl/Extended.pm Encode extension
ext/Encode/MANIFEST Encode extension
ext/Encode/README Encode extension
ext/Encode/t/Encode.t Encode extension test
-ext/Encode/t/Japanese.t Encode extension test
+ext/Encode/t/japanese.pl Encode extension
+ext/Encode/t/JP.t Encode extension test
ext/Encode/t/table.euc Encode extension test
ext/Encode/t/table.ref Encode extension test
+ext/Encode/t/table.rnd Encode extension
+ext/Encode/t/table.utf8 Encode extension
ext/Encode/t/Tcl.t Encode extension test
+ext/Encode/TW/Makefile.PL Encode extension
+ext/Encode/TW/TW.pm Encode extension
ext/Errno/ChangeLog Errno perl module change log
ext/Errno/Errno.t See if Errno works
ext/Errno/Errno_pm.PL Errno perl module create script
ext/threads/shared/typemap thread::shared types
ext/threads/t/basic.t ithreads
ext/threads/t/end.t Test end functions
-ext/threads/t/libc.t testing libc functions for threadsafetyness
ext/threads/t/join.t Testing the join function
+ext/threads/t/libc.t testing libc functions for threadsafetyness
ext/threads/t/stress_cv.t Test with multiple threads, coderef cv argument.
ext/threads/t/stress_re.t Test with multiple threads, string cv argument and regexes.
ext/threads/t/stress_string.t Test with multiple threads, string cv argument.
os2/OS2/Process/MANIFEST system() constants in a module
os2/OS2/Process/Process.pm system() constants in a module
os2/OS2/Process/Process.xs system() constants in a module
+os2/OS2/Process/t/os2_process.t Tests
+os2/OS2/Process/t/os2_process_kid.t Tests
+os2/OS2/Process/t/os2_process_text.t Tests
os2/OS2/REXX/Changes DLL access module
os2/OS2/REXX/DLL/Changes DLL access module
os2/OS2/REXX/DLL/DLL.pm DLL access module
d_Gconvert='gconvert((x),(n),(t),(b))'
d_Gconvert='gcvt((x),(n),(b))'
d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ If you are not content with these choices, use gconvert_preference
+ and gconvert_ld_preference, which if present are space-separated
+ lists of functions to try with calling convention of gcvt,
+ respectively for doubles and long doubles.
d_getcwd (d_getcwd.U):
This variable conditionally defines the HAS_GETCWD symbol, which
# Package name : perl5
# Source directory : .
-# Configuration time: Tue Jan 22 18:37:28 EET 2002
+# Configuration time: Sun Feb 17 04:40:47 EET 2002
# Configured by : jhi
# Target system : osf1 alpha.hut.fi v4.0 878 alpha
ccversion='V5.6-082'
cf_by='jhi'
cf_email='yourname@yourhost.yourplace.com'
-cf_time='Tue Jan 22 18:37:28 EET 2002'
+cf_time='Sun Feb 17 04:40:47 EET 2002'
charsize='1'
chgrp=''
chmod='chmod'
path_sep=':'
perl5='perl'
perl=''
-perl_patchlevel='14368'
+perl_patchlevel='14709'
perladmin='yourname@yourhost.yourplace.com'
perllibs='-lm -lutil'
perlpath='/opt/perl/bin/perl5.7.2'
vendorprefix=''
vendorprefixexp=''
version='5.7.2'
-version_patchlevel_string='version 7 subversion 2 patch 14368'
+version_patchlevel_string='version 7 subversion 2 patch 14709'
versiononly='define'
vi=''
voidflags='15'
PERL_API_REVISION=5
PERL_API_VERSION=5
PERL_API_SUBVERSION=0
-PERL_PATCHLEVEL=14368
+PERL_PATCHLEVEL=14709
PERL_CONFIG_SH=true
# Variables propagated from previous config.sh file.
pp_sys_cflags='ccflags="$ccflags -DNO_EFF_ONLY_OK"'
/*
* Package name : perl5
* Source directory : .
- * Configuration time: Tue Jan 22 18:37:28 EET 2002
+ * Configuration time: Sun Feb 17 04:40:47 EET 2002
* Configured by : jhi
* Target system : osf1 alpha.hut.fi v4.0 878 alpha
*/
* If defined, this macro indicates that the C compiler can handle
* function prototypes.
*/
-/* PROTO_:
+/* _:
* This macro is used to declare function parameters for folks who want
* to make declarations with prototypes using a different style than
* the above macros. Use double parentheses. For example:
*
- * int main PROTO_((int argc, char *argv[]));
+ * int main _((int argc, char *argv[]));
*/
#define CAN_PROTOTYPE /**/
#ifdef CAN_PROTOTYPE
-#define PROTO_(args) args
+#define _(args) args
#else
-#define PROTO_(args) ()
+#define _(args) ()
#endif
/* SH_PATH:
=head1 SYNOPSIS
-This is a port of Perl version 5 to VOS. Perl is a scripting or
-macro language that is popular on many systems. See L<perlbook>
-for a number of good books on Perl.
+This file contains notes for building perl on the Stratus VOS
+operating system. Perl is a scripting or macro language that is
+popular on many systems. See L<perlbook> for a number of good
+books on Perl.
These are instructions for building Perl from source. Most people can
simply download a pre-compiled distribution from the VOS anonymous FTP
unbundling the Perl distribution file are at
ftp://ftp.stratus.com/pub/vos/utility/utility.html.
+If you are running VOS Release 14.4.1 or later, you can obtain a
+pre-compiled, supported copy of perl by purchasing Release 2.0.1
+of the VOS GNU C++ and GNU Tools product from Stratus
+Technologies.
+
+=head2 Multiple methods to build perl for VOS
+
+If you elect to build perl from its source code, you have several
+different ways that you can build perl. The method that you use
+depends on the version of VOS that you are using and on the
+architecture of you Stratus hardware platform.
+
+=over 5
+
+=item 1
+
+If you have a Stratus XA2000 (Motorola 68k-based) platform, you
+must build perl using the alpha version of VOS POSIX support and
+using the VOS Standard C Cross-compiler. You must build perl on
+VOS Release 14.1.0 (or later) on an XA/R or Continuum platform.
+
+This version of perl is properly called "miniperl" because it
+does not contain the full perl functionality.
+
+You must build perl with the compile_perl.cm command macro found
+in the vos subdirectory.
+
+=item 2
+
+If you have a Stratus XA/R (Intel i860-based) platform, you must
+build perl using the alpha version of VOS POSIX support and using
+the VOS Standard C compiler or cross-compiler. You must build
+perl on VOS Release 14.1.0 (or later) on an XA/R or Continuum
+platform.
+
+This version of perl is properly called "miniperl" because it
+does not contain the full perl functionality.
+
+You must build perl with the compile_perl.cm command macro found
+in the vos subdirectory.
+
+=item 3
+
+If you have a Stratus Continuum (PARISC-based) platform that is
+running a version of VOS earlier than VOS 14.3.0, you must build
+perl using the alpha version of VOS POSIX support and using the
+VOS Standard C compiler or cross-compiler. You must build perl
+on VOS Release 14.1.0 (or later) on an XA/R or Continuum
+platform.
+
+This version of perl is properly called "miniperl" because it
+does not contain the full perl functionality.
+
+You must build perl with the compile_perl.cm command macro found
+in the vos subdirectory.
+
+=item 4
+
+If you have a Stratus Continuum (PARISC-based) platform that is
+running VOS Release 14.3.0 through VOS Release 14.4.0, you must
+build perl using the generally-available version of VOS POSIX
+support, and using either the VOS Standard C compiler or the VOS
+GNU C compiler. You must build perl on VOS Release 14.3.0 (or
+later) on a Continuum platform.
+
+This version of perl is properly called "miniperl" because it
+does not contain the full perl functionality.
+
+You must build perl with the compile_perl.cm command macro found
+in the vos subdirectory.
+
+=item 5
+
+If you have a Stratus Continuum (PA-RISC-based) platform that is
+running VOS Release 14.4.1 or later, you must build perl using
+the generally-available version of VOS POSIX support. You must
+use the VOS GNU C compiler and the VOS GNU Tools product. You
+must build perl on VOS Release 14.4.1 (or later) on a Continuum
+platform.
+
+This version of perl is properly called "full perl" because it
+contains the full perl functionality.
+
+You must use the supplied Configure script and makefiles to build
+perl.
+
+=back
+
=head2 Stratus POSIX Support
Note that there are two different implementations of POSIX.1
support on VOS. There is an alpha version of POSIX that is
available from the Stratus anonymous ftp site
-(ftp://ftp.stratus.com/pub/vos/posix/). There is
-a generally-available version of POSIX that comes with the VOS
-Standard C Compiler or VOS C runtime in VOS Release 14.3.0 or
-higher. This port of perl will compile and bind with either
-version of POSIX.
+(ftp://ftp.stratus.com/pub/vos/posix/alpha/alpha.html). There
+is a generally-available version of POSIX that comes with VOS
+Release 14.3.0 or higher. This port of POSIX will compile and
+bind with either version of POSIX.
Most of the Perl features should work on VOS regardless of which
version of POSIX that you are using. However, the alpha version
If you are using the generally-available version of VOS POSIX
support, then you should also acquire the VOS GNU C/C++ Compiler
-and GNU Tools product because it provides many common Unix or
-POSIX commands. When perl is built with this version of POSIX
-support, it assumes that it can find "bash", "sed" and other
-POSIX-compatible commands in the directory
+and GNU Tools product. When perl is built with this version of
+POSIX support, it assumes that it can find "bash", "sed" and
+other POSIX-compatible commands in the directory
/system/gnu_library/bin.
=back
-To build perl 5, change to the "vos" subdirectory and type the
-command "compile_perl -processor X", where X is the processor
-type (mc68020, i80860, pa7100, pa8000) that you wish to use.
-Note that the generally-available version of POSIX.1 support is
-not available for the mc68020 or i80860 processors.
+To build perl using the supplied VOS command macros, change to
+the "vos" subdirectory and type the command "compile_perl
+-processor X", where X is the processor type (mc68020, i80860,
+pa7100, pa8000) that you wish to use. Note that the
+generally-available version of POSIX.1 support is not available
+for the mc68020 or i80860 processors.
Use the "-version alpha" control argument to build perl with
the alpha version of POSIX support, and use the "-version
that code compiled for the pa8000 processor type can execute on
the PA8000, PA8500 and PA8600 processors.
-=head2 Installing Perl 5 on VOS
+To build perl using the supplied Configure script and makefiles,
+execute the following commands.
-=over 4
+ !add_library_path command >system>gnu_library>bin -after '(current_dir)'
+ !bash
+ gzip -d perl-5.8.0.tar.gz
+ tar -xvf perl-5.8.0.tar
+ cd perl-5.8.0
+ Configure -d
+ gmake
-=item 1
+If you wish to run the test cases, type:
-Create the directory >system>ported>command_library.
+ gmake test
-=item 2
+=head2 Installing Perl 5 on VOS
-Copy the appropriate version of the perl program module to
-this directory. For example, with your current directory
-set to the top-level directory of Perl 5, to install the
-executable program module for the Motorola 68K
-architecture, enter:
+=over 4
- !copy_file vos>obj>perl.pm >system>ported>command_library>*
+=item 1
-(If you wish to use both Perl version 4 and Perl version 5,
-you must give them different names; for example, perl.pm
-and perl5.pm).
+If you have built perl using the Configure script, ensure that
+you have modify permission to >system>ported and type
-=item 3
+ gmake install
-Create the directory >system>ported>perl>lib.
+=item 2
-=item 4
+If you have built perl using any of the other methods, type
-Copy all of the files and subdirectories from the lib
-subdirectory into this new directory. For example, with
-the current directory set to the top-level directory of the
-perl distribution, enter:
+ install_perl -processor PROCESSOR -name NAME
- !copy_dir lib >system>ported>perl>lib>5.7
+where PROCESSOR is mc68020, i80860, pa7100, or pa8000, as
+appropriate, and NAME is perl or perl5, according to which name
+you wish to use.
-=item 5
+This command macro will install perl and all of its related
+files in the proper directories.
+
+=item 3
While there are currently no architecture-specific
extensions or modules distributed with perl, the following
directories can be used to hold such files:
- >system>ported>perl>lib>5.7.68k
- >system>ported>perl>lib>5.7.860
- >system>ported>perl>lib>5.7.7100
- >system>ported>perl>lib>5.7.8000
+ >system>ported>lib>perl5>5.8.0>68k
+ >system>ported>lib>perl5>5.8.0>860
+ >system>ported>lib>perl5>5.8.0>7100
+ >system>ported>lib>perl5>5.8.0>8000
-=item 6
+=item 4
Site-specific perl extensions and modules can be installed in one of
two places. Put architecture-independent files into:
- >system>ported>perl>lib>site>5.7
+ >system>ported>lib>perl5>site_perl>5.8.0
-Put architecture-dependent files into one of the following
-directories:
+Put site-specific architecture-dependent files into one of the
+following directories:
- >system>ported>perl>lib>site>5.7.68k
- >system>ported>perl>lib>site>5.7.860
- >system>ported>perl>lib>site>5.7.7100
- >system>ported>perl>lib>site>5.7.8000
+ >system>ported>lib>perl5>site_perl>5.8.0>68k
+ >system>ported>lib>perl5>site_perl>5.8.0>860
+ >system>ported>lib>perl5>site_perl>5.8.0>7100
+ >system>ported>lib>perl5>site_perl>5.8.0>8000
-=item 7
+=item 5
You can examine the @INC variable from within a perl program
to see the order in which Perl searches these directories.
excellent books available on the Perl language; consult a book
seller.
+If you want a supported version of perl for VOS, purchase the VOS
+GNU C++ and GNU Tools Release 2.0.1 product from Stratus
+Technologies, along with a support contract (or from anyone else
+who will sell you support).
+
=head1 AUTHOR
Paul Green (Paul.Green@stratus.com)
=head1 LAST UPDATE
-November 29, 2001
+February 15, 2001
=cut
$preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
sub TIEHASH { bless {%preconfig} }
ENDOFSET
+ # Extract the name of the DLL from the makefile to avoid duplication
+ my ($f) = grep -r, qw(GNUMakefile Makefile);
+ my $dll;
+ if (open my $fh, '<', $f) {
+ while (<$fh>) {
+ $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
+ }
+ }
+ print CONFIG <<ENDOFSET if $dll;
+\$preconfig{dll_name} = '$dll';
+ENDOFSET
} else {
print CONFIG <<'ENDOFSET';
sub TIEHASH { bless {} }
UNLOCK_FDPID_MUTEX;
(void)SvUPGRADE(sv, SVt_IV);
SvIVX(sv) = pid;
- if (!was_fdopen) {
- PerlIO_close(fp);
+ if (was_fdopen) {
+ /* need to close fp without closing underlying fd */
+ int ofd = PerlIO_fileno(fp);
+ int dupfd = PerlLIO_dup(ofd);
+ PerlIO_close(fp);
+ PerlLIO_dup2(dupfd,ofd);
+ PerlLIO_close(dupfd);
}
+ else
+ PerlIO_close(fp);
}
fp = saveifp;
PerlIO_clearerr(fp);
= @$self{qw'curstash warnings hints'};
my $op = $form->ROOT;
my $kid;
- return "\f." if $op->first->name eq 'stub';
+ return "\f." if $op->first->name eq 'stub'
+ || $op->first->name eq 'nextstate';
$op = $op->first->first; # skip leavewrite, lineseq
while (not null $op) {
$op = $op->sibling; # skip nextstate
my $kid = $op->first->sibling;
return $name if null $kid;
my $first;
+ $name = "socketpair" if $name eq "sockpair";
if (defined prototype("CORE::$name")
&& prototype("CORE::$name") =~ /^;?\*/
&& $kid->name eq "rv2gv") {
sub escape_extended_re {
my($str) = @_;
$str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
- $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
+ $str =~ s/([[:^print:]])/
+ ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
$str =~ s/\n/\n\f/g;
return $str;
}
--- /dev/null
+package Encode::CN;
+use Encode;
+our $VERSION = '0.02';
+use XSLoader;
+XSLoader::load('Encode::CN',$VERSION);
+
+1;
+__END__
use strict;
use ExtUtils::MakeMaker;
-my %tables = (EUC_JP => ['euc-jp.ucm'],
- JIS0208 => ['jis0208.enc'],
- JIS0212 => ['jis0212.enc'],
- SHIFTJIS => ['shiftjis.enc'],
+my %tables = (EUC_CN => ['euc-cn.enc'],
+ GB2312 => ['gb2312.enc'],
+ GB12345 => ['gb12345.enc'],
+ CP936 => ['cp936.enc'],
);
-my $name = 'Japanese';
+my $name = 'CN';
WriteMakefile(
INC => "-I..",
+++ /dev/null
-package Encode::Japanese;
-use Encode;
-our $VERSION = '0.01';
-use XSLoader;
-XSLoader::load('Encode::Japanese',$VERSION);
-1;
-__END__
-
package Encode;
use strict;
-our $VERSION = '0.30';
+our $VERSION = '0.40';
require DynaLoader;
require Exporter;
--- /dev/null
+package Encode::JP;
+use Encode;
+our $VERSION = '0.02';
+use XSLoader;
+XSLoader::load('Encode::JP',$VERSION);
+
+use Encode::JP::JIS;
+use Encode::JP::ISO_2022_JP;
+
+1;
+__END__
use strict;
use ExtUtils::MakeMaker;
-my %tables = (EUC_JP => ['euc-jp.ucm'],
- JIS0208 => ['jis0208.enc'],
- JIS0212 => ['jis0212.enc'],
- SHIFTJIS => ['shiftjis.enc'],
+my %tables = (EUC_JP => ['euc-jp.enc'],
+ MACJAPAN => ['macJapan.enc'],
+ CP932 => ['cp932.enc'],
);
-my $name = 'Japanese';
+my $name = 'JP';
WriteMakefile(
INC => "-I..",
--- /dev/null
+package Encode::KR;
+use Encode;
+our $VERSION = '0.02';
+use XSLoader;
+XSLoader::load('Encode::KR',$VERSION);
+
+1;
+__END__
+
+todo:
+
use strict;
use ExtUtils::MakeMaker;
-my %tables = (EUC_JP => ['euc-jp.ucm'],
- JIS0208 => ['jis0208.enc'],
- JIS0212 => ['jis0212.enc'],
- SHIFTJIS => ['shiftjis.enc'],
+my %tables = (EUC_KR => ['euc-kr.enc'],
+ KSC5601 => ['ksc5601.enc'],
);
-my $name = 'Japanese';
+my $name = 'KR';
WriteMakefile(
INC => "-I..",
-Encode.xs
+CN/Makefile.PL
+CN/CN.pm
+Encode/euc-jp.ucm
Encode/11643-1.enc
Encode/11643-2.enc
Encode/2022-cn.enc
Encode/8859-8.ucm
Encode/8859-9.enc
Encode/8859-9.ucm
-Encode/HZ.enc
Encode/ascii.enc
Encode/ascii.ucm
Encode/big5.enc
Encode/gb1988.enc
Encode/gb2312.enc
Encode/gsm0338.enc
+Encode/HZ.enc
Encode/ir-197.enc
Encode/jis0201.enc
Encode/jis0208.enc
Encode/macUkraine.enc
Encode/nextstep.enc
Encode/nextstep.ucm
+Encode/roman8.enc
Encode/posix-bc.enc
Encode/posix-bc.ucm
-Encode/roman8.enc
Encode/roman8.ucm
Encode/shiftjis.enc
Encode/symbol.enc
Encode/symbol.ucm
Encode/viscii.enc
Encode/viscii.ucm
+Encode/jis0201.ucm
+Encode.pm
+Encode.xs
+JP/Makefile.PL
+JP/JP.pm
+KR/Makefile.PL
+KR/KR.pm
MANIFEST
Makefile.PL
README
+TW/Makefile.PL
+TW/TW.pm
compile
encengine.c
encode.h
-Encode.pm
lib/Encode/Encoding.pm
lib/Encode/Internal.pm
+lib/Encode/iso10646_1.pm
lib/Encode/Tcl.pm
+lib/Encode/ucs2_le.pm
+lib/Encode/Unicode.pm
+lib/Encode/utf8.pm
+lib/Encode/XS.pm
lib/Encode/Tcl/Escape.pm
lib/Encode/Tcl/Extended.pm
lib/Encode/Tcl/HanZi.pm
lib/Encode/Tcl/Table.pm
-lib/Encode/Unicode.pm
-lib/Encode/XS.pm
-lib/Encode/iso10646_1.pm
-lib/Encode/ucs2_le.pm
-lib/Encode/utf8.pm
+lib/Encode/JP/Tr.pm
+lib/Encode/JP/ISO_2022_JP.pm
+lib/Encode/JP/H2Z.pm
+lib/Encode/JP/Constants.pm
+lib/Encode/JP/JIS.pm
lib/EncodeFormat.pod
t/Tcl.t
+t/Encode.t
+t/table.euc
+t/table.ref
+t/table.utf8
+t/table.rnd
+t/japanese.pl
+t/JP.t
use strict;
use ExtUtils::MakeMaker;
-my %tables = (EUC_JP => ['euc-jp.ucm'],
- JIS0208 => ['jis0208.enc'],
- JIS0212 => ['jis0212.enc'],
- SHIFTJIS => ['shiftjis.enc'],
+my %tables = (BIG5 => ['big5.enc'],
+ CP950 => ['cp950.enc'],
);
-my $name = 'Japanese';
+my $name = 'TW';
WriteMakefile(
INC => "-I..",
--- /dev/null
+package Encode::TW;
+use Encode;
+our $VERSION = '0.02';
+use XSLoader;
+XSLoader::load('Encode::TW',$VERSION);
+
+1;
+__END__
+
+todo: HZ (Escape-based)
--- /dev/null
+#
+# $Id: Constants.pm,v 1.2 2001/05/18 05:14:38 dankogai Exp dankogai $
+#
+
+package Encode::JP::Constants;
+
+use strict;
+use vars qw($RCSID $VERSION);
+
+$RCSID = q$Id: Constants.pm,v 1.2 2001/05/18 05:14:38 dankogai Exp dankogai $;
+$VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use Carp;
+
+BEGIN {
+ use Exporter;
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @EXPORT = qw();
+ @EXPORT_OK = qw(%CHARCODE %ESC %RE);
+ %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK, @EXPORT ] );
+}
+
+use vars @EXPORT_OK;
+
+my %_0208 = (
+ 1978 => '\e\$\@',
+ 1983 => '\e\$B',
+ 1990 => '\e&\@\e\$B',
+ );
+
+%CHARCODE = (
+ UNDEF_EUC => "\xa2\xae", # ¢® in EUC
+ UNDEF_SJIS => "\x81\xac", # ¢® in SJIS
+ UNDEF_JIS => "\xa2\xf7", # ¢÷ -- used in unicode
+ UNDEF_UNICODE => "\x20\x20", # ¢÷ -- used in unicode
+ );
+
+%ESC = (
+ JIS_0208 => "\e\$B",
+ JIS_0212 => "\e\$(D",
+ ASC => "\e\(B",
+ KANA => "\e\(I",
+ );
+
+%RE =
+ (
+ ASCII => '[\x00-\x7f]',
+ BIN => '[\x00-\x06\x7f\xff]',
+ EUC_0212 => '\x8f[\xa1-\xfe][\xa1-\xfe]',
+ EUC_C => '[\xa1-\xfe][\xa1-\xfe]',
+ EUC_KANA => '\x8e[\xa1-\xdf]',
+ JIS_0208 => "$_0208{1978}|$_0208{1983}|$_0208{1990}",
+ JIS_0212 => "\e" . '\$\(D',
+ JIS_ASC => "\e" . '\([BJ]',
+ JIS_KANA => "\e" . '\(I',
+ SJIS_C => '[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]',
+ SJIS_KANA => '[\xa1-\xdf]',
+ UTF8 => '[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf]'
+ );
+
+1;
+
--- /dev/null
+#
+# $Id: H2Z.pm,v 0.77 2002/01/14 11:06:55 dankogai Exp $
+#
+
+package Encode::JP::H2Z;
+
+use strict;
+use vars qw($RCSID $VERSION);
+
+$RCSID = q$Id: H2Z.pm,v 0.77 2002/01/14 11:06:55 dankogai Exp $;
+$VERSION = do { my @r = (q$Revision: 0.77 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use Carp;
+
+use Encode::JP::Constants qw(:all);
+
+use vars qw(%_D2Z $_PAT_D2Z
+ %_Z2D $_PAT_Z2D
+ %_H2Z $_PAT_H2Z
+ %_Z2H $_PAT_Z2H);
+
+%_H2Z = (
+ "\x8e\xa1" => "\xa1\xa3", #¡£
+ "\x8e\xa2" => "\xa1\xd6", #¡Ö
+ "\x8e\xa3" => "\xa1\xd7", #¡×
+ "\x8e\xa4" => "\xa1\xa2", #¡¢
+ "\x8e\xa5" => "\xa1\xa6", #¡¦
+ "\x8e\xa6" => "\xa5\xf2", #¥ò
+ "\x8e\xa7" => "\xa5\xa1", #¥¡
+ "\x8e\xa8" => "\xa5\xa3", #¥£
+ "\x8e\xa9" => "\xa5\xa5", #¥¥
+ "\x8e\xaa" => "\xa5\xa7", #¥§
+ "\x8e\xab" => "\xa5\xa9", #¥©
+ "\x8e\xac" => "\xa5\xe3", #¥ã
+ "\x8e\xad" => "\xa5\xe5", #¥å
+ "\x8e\xae" => "\xa5\xe7", #¥ç
+ "\x8e\xaf" => "\xa5\xc3", #¥Ã
+ "\x8e\xb0" => "\xa1\xbc", #¡¼
+ "\x8e\xb1" => "\xa5\xa2", #¥¢
+ "\x8e\xb2" => "\xa5\xa4", #¥¤
+ "\x8e\xb3" => "\xa5\xa6", #¥¦
+ "\x8e\xb4" => "\xa5\xa8", #¥¨
+ "\x8e\xb5" => "\xa5\xaa", #¥ª
+ "\x8e\xb6" => "\xa5\xab", #¥«
+ "\x8e\xb7" => "\xa5\xad", #¥
+ "\x8e\xb8" => "\xa5\xaf", #¥¯
+ "\x8e\xb9" => "\xa5\xb1", #¥±
+ "\x8e\xba" => "\xa5\xb3", #¥³
+ "\x8e\xbb" => "\xa5\xb5", #¥µ
+ "\x8e\xbc" => "\xa5\xb7", #¥·
+ "\x8e\xbd" => "\xa5\xb9", #¥¹
+ "\x8e\xbe" => "\xa5\xbb", #¥»
+ "\x8e\xbf" => "\xa5\xbd", #¥½
+ "\x8e\xc0" => "\xa5\xbf", #¥¿
+ "\x8e\xc1" => "\xa5\xc1", #¥Á
+ "\x8e\xc2" => "\xa5\xc4", #¥Ä
+ "\x8e\xc3" => "\xa5\xc6", #¥Æ
+ "\x8e\xc4" => "\xa5\xc8", #¥È
+ "\x8e\xc5" => "\xa5\xca", #¥Ê
+ "\x8e\xc6" => "\xa5\xcb", #¥Ë
+ "\x8e\xc7" => "\xa5\xcc", #¥Ì
+ "\x8e\xc8" => "\xa5\xcd", #¥Í
+ "\x8e\xc9" => "\xa5\xce", #¥Î
+ "\x8e\xca" => "\xa5\xcf", #¥Ï
+ "\x8e\xcb" => "\xa5\xd2", #¥Ò
+ "\x8e\xcc" => "\xa5\xd5", #¥Õ
+ "\x8e\xcd" => "\xa5\xd8", #¥Ø
+ "\x8e\xce" => "\xa5\xdb", #¥Û
+ "\x8e\xcf" => "\xa5\xde", #¥Þ
+ "\x8e\xd0" => "\xa5\xdf", #¥ß
+ "\x8e\xd1" => "\xa5\xe0", #¥à
+ "\x8e\xd2" => "\xa5\xe1", #¥á
+ "\x8e\xd3" => "\xa5\xe2", #¥â
+ "\x8e\xd4" => "\xa5\xe4", #¥ä
+ "\x8e\xd5" => "\xa5\xe6", #¥æ
+ "\x8e\xd6" => "\xa5\xe8", #¥è
+ "\x8e\xd7" => "\xa5\xe9", #¥é
+ "\x8e\xd8" => "\xa5\xea", #¥ê
+ "\x8e\xd9" => "\xa5\xeb", #¥ë
+ "\x8e\xda" => "\xa5\xec", #¥ì
+ "\x8e\xdb" => "\xa5\xed", #¥í
+ "\x8e\xdc" => "\xa5\xef", #¥ï
+ "\x8e\xdd" => "\xa5\xf3", #¥ó
+ "\x8e\xde" => "\xa1\xab", #¡«
+ "\x8e\xdf" => "\xa1\xac", #¡¬
+);
+
+%_D2Z = (
+ "\x8e\xb6\x8e\xde" => "\xa5\xac", #¥¬
+ "\x8e\xb7\x8e\xde" => "\xa5\xae", #¥®
+ "\x8e\xb8\x8e\xde" => "\xa5\xb0", #¥°
+ "\x8e\xb9\x8e\xde" => "\xa5\xb2", #¥²
+ "\x8e\xba\x8e\xde" => "\xa5\xb4", #¥´
+ "\x8e\xbb\x8e\xde" => "\xa5\xb6", #¥¶
+ "\x8e\xbc\x8e\xde" => "\xa5\xb8", #¥¸
+ "\x8e\xbd\x8e\xde" => "\xa5\xba", #¥º
+ "\x8e\xbe\x8e\xde" => "\xa5\xbc", #¥¼
+ "\x8e\xbf\x8e\xde" => "\xa5\xbe", #¥¾
+ "\x8e\xc0\x8e\xde" => "\xa5\xc0", #¥À
+ "\x8e\xc1\x8e\xde" => "\xa5\xc2", #¥Â
+ "\x8e\xc2\x8e\xde" => "\xa5\xc5", #¥Å
+ "\x8e\xc3\x8e\xde" => "\xa5\xc7", #¥Ç
+ "\x8e\xc4\x8e\xde" => "\xa5\xc9", #¥É
+ "\x8e\xca\x8e\xde" => "\xa5\xd0", #¥Ð
+ "\x8e\xcb\x8e\xde" => "\xa5\xd3", #¥Ó
+ "\x8e\xcc\x8e\xde" => "\xa5\xd6", #¥Ö
+ "\x8e\xcd\x8e\xde" => "\xa5\xd9", #¥Ù
+ "\x8e\xce\x8e\xde" => "\xa5\xdc", #¥Ü
+ "\x8e\xca\x8e\xdf" => "\xa5\xd1", #¥Ñ
+ "\x8e\xcb\x8e\xdf" => "\xa5\xd4", #¥Ô
+ "\x8e\xcc\x8e\xdf" => "\xa5\xd7", #¥×
+ "\x8e\xcd\x8e\xdf" => "\xa5\xda", #¥Ú
+ "\x8e\xce\x8e\xdf" => "\xa5\xdd", #¥Ý
+ "\x8e\xb3\x8e\xde" => "\xa5\xf4", #¥ô
+);
+
+# init only once;
+
+#$_PAT_D2Z = join("|", keys %_D2Z);
+#$_PAT_H2Z = join("|", keys %_H2Z);
+
+%_Z2H = reverse %_H2Z;
+%_Z2D = reverse %_D2Z;
+
+#$_PAT_Z2H = join("|", keys %_Z2H);
+#$_PAT_Z2D = join("|", keys %_Z2D);
+
+sub h2z {
+ my $r_str = shift;
+ my ($keep_dakuten) = @_;
+ my $n = 0;
+ unless ($keep_dakuten){
+ $n = (
+ $$r_str =~ s(
+ ($RE{EUC_KANA}
+ (?:\x8e[\xde\xdf])?)
+ ){
+ my $str = $1;
+ $_D2Z{$str} || $_H2Z{$str} ||
+ # in case dakuten and handakuten are side-by-side!
+ $_H2Z{substr($str,0,2)} . $_H2Z{substr($str,2,2)};
+ }eogx
+ );
+ }else{
+ $n = (
+ $$r_str =~ s(
+ ($RE{EUC_KANA})
+ ){
+ $_H2Z{$1};
+ }eogx
+ );
+ }
+ $n;
+}
+
+sub z2h {
+ my $r_str = shift;
+ my $n = (
+ $$r_str =~ s(
+ ($RE{EUC_C}|$RE{EUC_0212}|$RE{EUC_KANA})
+ ){
+ $_Z2D{$1} || $_Z2H{$1} || $1;
+ }eogx
+ );
+ $n;
+}
+
+1;
--- /dev/null
+package Encode::JP::ISO_2022_JP;
+use Encode::JP;
+use Encode::JP::JIS;
+use Encode::JP::H2Z;
+use base 'Encode::Encoding';
+
+
+my $canon = 'iso-2022-jp';
+my $obj = bless {name => $canon}, __PACKAGE__;
+$obj->Define($canon);
+
+#
+# decode is identical to 7bit-jis
+#
+
+sub decode
+{
+ my ($obj,$str,$chk) = @_;
+ return Encode::decode('7bit-jis', $str, $chk);
+}
+
+# iso-2022-jp = 7bit-jis with all x201 (Hankaku) converted to
+# x208 equivalent (Zenkaku)
+
+sub encode
+{
+ my ($obj,$str,$chk) = @_;
+ my $euc = Encode::encode('euc-jp', $str, $chk);
+ &Encode::JP::H2Z::h2z(\$euc);
+ return &Encode::JP::JIS::euc_jis(\$euc);
+}
+
+1;
+__END__
--- /dev/null
+package Encode::JP::JIS;
+use Encode::JP;
+use base 'Encode::Encoding';
+
+# Just for the time being, we implement jis-7bit
+# encoding via EUC
+
+my $canon = '7bit-jis';
+my $obj = bless {name => $canon}, __PACKAGE__;
+$obj->Define($canon);
+
+sub decode
+{
+ my ($obj,$str,$chk) = @_;
+ my $res = $str;
+ jis_euc(\$res);
+ return Encode::decode('euc-jp', $euc, $chk);
+}
+
+sub encode
+{
+ my ($obj,$str,$chk) = @_;
+ my $res = Encode::encode('euc-jp', $str, $chk);
+ euc_jis(\$res);
+ return $res;
+}
+
+use Encode::JP::Constants qw(:all);
+
+# JIS<->EUC
+
+sub jis_euc {
+ my $r_str = shift;
+ $$r_str =~ s(
+ ($RE{JIS_0212}|$RE{JIS_0208}|$RE{JIS_ASC}|$RE{JIS_KANA})
+ ([^\e]*)
+ )
+ {
+ my ($esc, $str) = ($1, $2);
+ if ($esc !~ /$RE{JIS_ASC}/o) {
+ $str =~ tr/\x21-\x7e/\xa1-\xfe/;
+ if ($esc =~ /$RE{JIS_KANA}/o) {
+ $str =~ s/([\xa1-\xdf])/\x8e$1/og;
+ }
+ elsif ($esc =~ /$RE{JIS_0212}/o) {
+ $str =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og;
+ }
+ }
+ $str;
+ }geox;
+ $$r_str;
+}
+
+sub euc_jis{
+ my $r_str = shift;
+ $$r_str =~ s{
+ ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+)
+ }{
+ my $str = $1;
+ my $esc =
+ ( $str =~ tr/\x8E//d ) ? $ESC{KANA} :
+ ( $str =~ tr/\x8F//d ) ? $ESC{JIS_0212} :
+ $ESC{JIS_0208};
+ $str =~ tr/\xA1-\xFE/\x21-\x7E/;
+ $esc . $str . $ESC{ASC};
+ }geox;
+ $$r_str =~
+ s/\Q$ESC{ASC}\E
+ (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox;
+ $$r_str;
+}
+
+1;
+__END__
--- /dev/null
+#
+# $Id: Tr.pm,v 0.77 2002/01/14 11:06:55 dankogai Exp $
+#
+
+package Jcode::Tr;
+
+use strict;
+use vars qw($VERSION $RCSID);
+
+$RCSID = q$Id: Tr.pm,v 0.77 2002/01/14 11:06:55 dankogai Exp $;
+$VERSION = do { my @r = (q$Revision: 0.77 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+use Carp;
+
+use Jcode::Constants qw(:all);
+use vars qw(%_TABLE);
+
+sub tr {
+ # $prev_from, $prev_to, %table are persistent variables
+ my ($r_str, $from, $to, $opt) = @_;
+ my (@from, @to);
+ my $n = 0;
+
+ undef %_TABLE;
+ &_maketable($from, $to, $opt);
+
+ $$r_str =~ s(
+ ([\x80-\xff][\x00-\xff]|[\x00-\xff])
+ )
+ {defined($_TABLE{$1}) && ++$n ?
+ $_TABLE{$1} : $1}ogex;
+
+ return $n;
+}
+
+sub _maketable{
+ my( $from, $to, $opt ) = @_;
+
+ $from =~ s/($RE{EUC_0212}-$RE{EUC_0212})/&_expnd3($1)/geo;
+ $from =~ s/($RE{EUC_KANA}-$RE{EUC_KANA})/&_expnd2($1)/geo;
+ $from =~ s/($RE{EUC_C }-$RE{EUC_C })/&_expnd2($1)/geo;
+ $from =~ s/($RE{ASCII }-$RE{ASCII })/&_expnd1($1)/geo;
+ $to =~ s/($RE{EUC_0212}-$RE{EUC_0212})/&_expnd3($1)/geo;
+ $to =~ s/($RE{EUC_KANA}-$RE{EUC_KANA})/&_expnd2($1)/geo;
+ $to =~ s/($RE{EUC_C }-$RE{EUC_C })/&_expnd2($1)/geo;
+ $to =~ s/($RE{ASCII }-$RE{ASCII })/&_expnd1($1)/geo;
+
+ my @from = $from =~ /$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff]/go;
+ my @to = $to =~ /$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff]/go;
+
+ push @to, ($opt =~ /d/ ? '' : $to[-1]) x ($#from - $#to) if $#to < $#from;
+ @_TABLE{@from} = @to;
+
+}
+
+sub _expnd1 {
+ my ($str) = @_;
+ # s/\\(.)/$1/og; # I dunno what this was doing!?
+ my($c1, $c2) = unpack('CxC', $str);
+ if ($c1 <= $c2) {
+ for ($str = ''; $c1 <= $c2; $c1++) {
+ $str .= pack('C', $c1);
+ }
+ }
+ return $str;
+}
+
+sub _expnd2 {
+ my ($str) = @_;
+ my ($c1, $c2, $c3, $c4) = unpack('CCxCC', $str);
+ if ($c1 == $c3 && $c2 <= $c4) {
+ for ($str = ''; $c2 <= $c4; $c2++) {
+ $str .= pack('CC', $c1, $c2);
+ }
+ }
+ return $str;
+}
+
+sub _expnd3 {
+ my ($str) = @_;
+ my ($c1, $c2, $c3, $c4, $c5, $c6) = unpack('CCCxCCC', $str);
+ if ($c1 == $c4 && $c2 == $c5 && $c3 <= $c6) {
+ for ($str = ''; $c3 <= $c6; $c3++) {
+ $str .= pack('CCC', $c1, $c2, $c3);
+ }
+ }
+ return $str;
+}
+
+1;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ push @INC, '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bEncode\b/) {
print "1..0 # Skip: Encode was not built\n";
exit 0;
}
}
+use strict;
use Test;
use Encode qw(from_to encode decode
encode_utf8 decode_utf8
}
$| = 1;
}
+use strict;
use Test::More tests => 22;
use Encode;
use File::Basename;
use File::Spec;
use File::Compare;
-require_ok "Encode::Japanese";
+require_ok "Encode::JP";
+
+my ($src, $uni, $dst, $txt);
ok(defined(my $enc = find_encoding('euc-jp')));
ok($enc->isa('Encode::XS'));
my $ref = File::Spec->catfile($dir,"table.ref");
my $rnd = File::Spec->catfile($dir,"table.rnd");
print "# Basic decode test\n";
-open(my $src,"<",$euc) || die "Cannot open $euc:$!";
+open($src,"<",$euc) || die "Cannot open $euc:$!";
ok(defined($src) && fileno($src));
-my $txt = join('',<$src>);
-open(my $dst,">:utf8",$utf) || die "Cannot open $utf:$!";
+$txt = join('',<$src>);
+open($dst,">:utf8",$utf) || die "Cannot open $utf:$!";
ok(defined($dst) && fileno($dst));
-my $uni = $enc->decode($txt,1);
+$uni = $enc->decode($txt,1);
ok(defined($uni));
is(length($txt),0);
print $dst $uni;
ok(compare($utf,$ref) == 0);
print "# Basic encode test\n";
-open(my $src,"<:utf8",$ref) || die "Cannot open $ref:$!";
+open($src,"<:utf8",$ref) || die "Cannot open $ref:$!";
ok(defined($src) && fileno($src));
-my $uni = join('',<$src>);
-open(my $dst,">",$rnd) || die "Cannot open $rnd:$!";
+$uni = join('',<$src>);
+open($dst,">",$rnd) || die "Cannot open $rnd:$!";
ok(defined($dst) && fileno($dst));
-my $txt = $enc->encode($uni,1);
+$txt = $enc->encode($uni,1);
ok(defined($txt));
is(length($uni),0);
print $dst $txt;
is($enc->name,'euc-jp');
print "# src :encoding test\n";
-open(my $src,"<encoding(euc-jp)",$euc) || die "Cannot open $euc:$!";
+open($src,"<encoding(euc-jp)",$euc) || die "Cannot open $euc:$!";
ok(defined($src) && fileno($src));
-open(my $dst,">:utf8",$utf) || die "Cannot open $utf:$!";
+open($dst,">:utf8",$utf) || die "Cannot open $utf:$!";
ok(defined($dst) || fileno($dst));
-$out = select($dst);
+my $out = select($dst);
while (<$src>)
{
print;
{
#skip "Multi-byte write is broken",3;
print "# dst :encoding test\n";
- open(my $src,"<:utf8",$ref) || die "Cannot open $ref:$!";
+ open($src,"<:utf8",$ref) || die "Cannot open $ref:$!";
ok(defined($src) || fileno($src));
- open(my $dst,">encoding(euc-jp)",$rnd) || die "Cannot open $rnd:$!";
+ open($dst,">encoding(euc-jp)",$rnd) || die "Cannot open $rnd:$!";
ok(defined($dst) || fileno($dst));
my $out = select($dst);
while (<$src>)
--- /dev/null
+#
+use strict;
+#use blib;
+use Encode::Japanese;
+
+# print join("\n", Encode::encodings()),"\n";
# Now go back
cd ../..
+cp os2/*.t t/lib
# apparently don't reveal that unless you pass in -V.
# (This may all depend on local configurations too.)
+ # Recompute verbose with -Wl,-v to find GNU ld if present
+ verbose=`${cc:-cc} -v -Wl,-v -o try try.c 2>&1 | grep ld 2>&1`
+
myld=`echo $verbose| grep ld | awk '/\/ld/ {print $1}'`
# This assumes that gcc's output will not change, and that
# /full/path/to/ld will be the first word of the output.
- # Thus myld is something like opt/gnu/sparc-sun-solaris2.5/bin/ld
+ # Thus myld is something like /opt/gnu/sparc-sun-solaris2.5/bin/ld
- if $myld -V 2>&1 | grep "ld: Software Generation Utilities" >/dev/null 2>&1; then
+ # Allow that $myld may be '', due to changes in gcc's output
+ if ${myld:-ld} -V 2>&1 |
+ grep "ld: Software Generation Utilities" >/dev/null 2>&1; then
# Ok, /usr/ccs/bin/ld eventually does get called.
:
else
+ echo "Found GNU ld='$myld'" >&4
cat <<END >&2
NOTE: You are using GNU ld(1). GNU ld(1) might not build Perl. If you
package Net::Ping;
-# $Id: Ping.pm,v 1.16 2002/01/05 23:36:54 rob Exp $
+# $Id: Ping.pm,v 1.17 2002/02/18 01:25:11 rob Exp $
require 5.002;
require Exporter;
use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
inet_aton sockaddr_in );
use Carp;
+use Errno qw(ECONNREFUSED);
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.11";
+$VERSION = "2.12";
# Constants
my ($ret # The return value
);
- $@ = "";
+ $@ = ""; $! = 0;
$ret = $self -> tcp_connect( $ip, $timeout);
- $ret = 1 if $@ =~ /(Connection Refused|Unknown Error)/i;
+ $ret = 1 if $! == ECONNREFUSED # Connection refused
+ || $@ =~ /Unknown Error/i; # Special Win32 response?
$self->{"fh"}->close();
return($ret);
}
Net::Ping - check a remote host for reachability
-$Id: Ping.pm,v 1.16 2002/01/05 23:36:54 rob Exp $
+$Id: Ping.pm,v 1.17 2002/02/18 01:25:11 rob Exp $
=head1 SYNOPSIS
CHANGES
-------
+2.12 Feb 17 19:00 2002
+ - More general error determination for
+ better cross platform consistency and
+ foreign language support.
+ Spotted by arnaud@romeconcept.com
+ - Test changes for VMS (Craig Berry)
+
2.11 Feb 02 12:00 2002
- Test changes in case echo port is not available.
- Fix 110_icmp_inst.t to use icmp protocol
NAME
Net::Ping - check a remote host for reachability
- $Id: Ping.pm,v 1.16 2002/01/05 23:36:54 rob Exp $
+ $Id: Ping.pm,v 1.17 2002/02/18 01:25:11 rob Exp $
SYNOPSIS
use Net::Ping;
# Everything loaded fine
ok 1;
-if ($> and $^O ne 'VMS') {
+if (($> and $^O ne 'VMS')
+ or ($^O eq 'VMS'
+ and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) {
skip "icmp ping requires root privileges.", 1;
} else {
my $p = new Net::Ping "icmp";
END_OF_BLOCK
print HTML <<END_OF_HEAD;
-<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
-head>
+<head>
<title>$title</title>$csslink
<link rev="made" href="mailto:$Config{perladmin}" />
</head>
# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
-# $Id: Overstrike.pm,v 1.7 2002/01/28 01:55:42 eagle Exp $
+# $Id: Overstrike.pm,v 1.8 2002/02/17 04:38:03 eagle Exp $
#
# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000
# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>)
# Don't use the CVS revision as the version, since this module is also in Perl
# core and too many things could munge CVS magic revision strings. This
# number should ideally be the same as the CVS revision in podlators, however.
-$VERSION = 1.07;
+$VERSION = 1.08;
##############################################################################
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{width} - $$self{MARGIN};
while (length > $width) {
- if (s/^((?:(?:[^\n][\b])?[^\n]){0,$width})(\Z|\s+)//
- || s/^((?:(?:[^\n][\b])?[^\n]){$width})//) {
+ # This regex represents a single character, that's possibly underlined
+ # or in bold (in which case, it's three characters; the character, a
+ # backspace, and a character). Use [^\n] rather than . to protect
+ # against odd settings of $*.
+ my $char = '(?:[^\n][\b])?[^\n]';
+ if (s/^((?>$char){0,$width})(?:\Z|\s+)//) {
$output .= $spaces . $1 . "\n";
} else {
last;
package Tie::Memoize;
use Tie::Hash;
our @ISA = 'Tie::ExtraHash';
+our $VERSION = '1.0';
our $exists_token = \undef;
Perl_hab_GET
loadByOrdinal
pExtFCN
+ os2error
+ ResetWinError
+ CroakWinError
)]);
}
elsif ($PLATFORM eq 'MacOS') {
'--skip-strict', '--skip-warnings', # likewise
'--skip-ppport', # will not work without dynaloading.
# Most useful for OS2::Process:
- '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS)_',
+ '-M^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID)_',
'-F', '-DINCL_NLS -DINCL_BASE -DINCL_PM', # Define more symbols
'os2emx.h' # EMX version of OS/2 API
and warn("Can't build module with contants, falling back to no constants"),
package OS2::localMorphPM;
+# use strict;
-sub new { my ($c,$f) = @_; OS2::MorphPM($f); bless [shift], $c }
-sub DESTROY { OS2::UnMorphPM(shift->[0]) }
+sub new {
+ my ($c,$f) = @_;
+ OS2::MorphPM($f);
+ # print STDERR ">>>>>\n";
+ bless [$f], $c
+}
+sub DESTROY {
+ # print STDERR "<<<<<\n";
+ OS2::UnMorphPM(shift->[0])
+}
package OS2::Process;
BEGIN {
require Exporter;
- require DynaLoader;
+ require XSLoader;
#require AutoLoader;
- @ISA = qw(Exporter DynaLoader);
- $VERSION = "1.0";
- bootstrap OS2::Process;
+ our @ISA = qw(Exporter);
+ our $VERSION = "1.0";
+ XSLoader::load('OS2::Process', $VERSION);
}
# 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.
-@EXPORT = qw(
+our @EXPORT = qw(
P_BACKGROUND
P_DEBUG
P_DEFAULT
process_hentries
change_entry
change_entryh
+ process_hwnd
Title_set
Title
+ winTitle_set
+ winTitle
+ swTitle_set
+ bothTitle_set
WindowText
WindowText_set
WindowPos
WindowPos_set
+ hWindowPos
+ hWindowPos_set
WindowProcess
SwitchToProgram
+ DesktopWindow
ActiveWindow
+ ActiveWindow_set
ClassName
FocusWindow
FocusWindow_set
WindowFromId
WindowFromPoint
EnumDlgItem
+ EnableWindow
+ EnableWindowUpdate
+ IsWindowEnabled
+ IsWindowVisible
+ IsWindowShowing
+ WindowPtr
+ WindowULong
+ WindowUShort
+ SetWindowBits
+ SetWindowPtr
+ SetWindowULong
+ SetWindowUShort
get_title
set_title
);
+our @EXPORT_OK = qw(
+ ResetWinError
+ MPFROMSHORT
+ MPVOID
+ MPFROMCHAR
+ MPFROM2SHORT
+ MPFROMSH2CH
+ MPFROMLONG
+);
+
+our $AUTOLOAD;
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function. If a constant is not found then control is passed
# to the AUTOLOAD in AutoLoader.
- local($constname);
- ($constname = $AUTOLOAD) =~ s/.*:://;
- $val = constant($constname, @_ ? $_[0] : 0);
+ (my $constname = $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- ($pack,$file,$line) = caller;
+ die "Unsupported function $AUTOLOAD"
+ } else {
+ my ($pack,$file,$line) = caller;
die "Your vendor has not defined OS2::Process macro $constname, used at $file line $line.
";
}
goto &$AUTOLOAD;
}
+sub const_import {
+ require OS2::Process::Const;
+ my $sym = shift;
+ my ($err, $val) = OS2::Process::Const::constant($sym);
+ die $err if $err;
+ my $p = caller(1);
+
+ # no strict;
+
+ *{"$p\::$sym"} = sub () { $val };
+ (); # needed by import()
+}
+
+sub import {
+ my $class = shift;
+ my $ini = @_;
+ @_ = ($class,
+ map {
+ /^(HWND|WM|SC|SWP|WC|PROG|QW|EDI|WS|QWS|QWP|QWL|FF|FI|LS|FS|FCF|BS|MS|TBM|CF|CFI|FID)_/ ? const_import($_) : $_
+ } @_);
+ goto &Exporter::import if @_ > 1 or $ini == 0;
+}
+
# Preloaded methods go here.
sub Title () { (process_entry())[0] }
change_entry(@sw);
}
-sub swTitle_set {
+sub swTitle_set ($) {
my (@sw) = process_entry();
swTitle_set_sw(shift, @sw);
}
WindowText_set $sw[1], $title;
}
-sub winTitle_set {
+sub winTitle_set ($) {
my (@sw) = process_entry();
winTitle_set_sw(shift, @sw);
}
-sub bothTitle_set {
+sub winTitle () {
+ my (@sw) = process_entry();
+ my $h = OS2::localMorphPM->new(0);
+ WindowText $sw[1];
+}
+
+sub bothTitle_set ($) {
my (@sw) = process_entry();
my $t = shift;
winTitle_set_sw($t, @sw);
swTitle_set_sw($t, @sw);
}
-sub Title_set {
+sub Title_set ($) {
my $t = shift;
return 1 if sesmgr_title_set($t);
return 0 unless $^E == 372;
}
sub process_hentry { swentry_hexpand(process_swentry(@_)) }
+sub process_hwnd { process_hentry()->{owner_hwnd} }
my $swentry_size = swentry_size();
# Massage entries into the same order as WindowPos_set:
sub WindowPos ($) {
- my ($fl, $w, $h, $x, $y, $behind, $hwnd, @rest)
+ my ($fl, $h, $w, $y, $x, $behind, $hwnd, @rest)
= unpack 'L l4 L4', WindowSWP(shift);
($x, $y, $fl, $w, $h, $behind, @rest);
}
-sub ChildWindows ($) {
+# Put them into a hash
+sub hWindowPos ($) {
+ my %h;
+ @h{ qw(flags height width y x behind hwnd reserved1 reserved2) }
+ = unpack 'L l4 L4', WindowSWP(shift);
+ \%h;
+}
+
+my @SWP_keys = ( [qw(width height)], # SWP_SIZE=1
+ [qw(x y)], # SWP_MOVE=2
+ [qw(behind)] ); # SWP_ZORDER=3
+my %SWP_def;
+@SWP_def{ map @$_, @SWP_keys } = (0) x 20;
+
+# Get them from a hash
+sub hWindowPos_set ($$) {
+ my $hash = shift;
+ my $hwnd = (@_ ? shift : $hash->{hwnd} );
+ my $flags;
+ if (exists $hash->{flags}) {
+ $flags = $hash->{flags};
+ } else { # Set flags according to existing keys in $hash
+ $flags = 0;
+ for my $bit (0..2) {
+ exists $hash->{$_} and $flags |= (1<<$bit) for @{$SWP_keys[$bit]};
+ }
+ }
+ for my $bit (0..2) { # Check for required keys
+ next unless $flags & (1<<$bit);
+ exists $hash->{$_}
+ or die sprintf "key $_ required for flags=%#x", $flags
+ for @{$SWP_keys[$bit]};
+ }
+ my %h = (%SWP_def, flags => $flags, %$hash); # Avoid warnings
+ my ($x, $y, $fl, $w, $h, $behind) = @h{ qw(x y flags width height behind) };
+ WindowPos_set($hwnd, $x, $y, $fl, $w, $h, $behind);
+}
+
+sub ChildWindows (;$) {
+ my $hm = OS2::localMorphPM->new(0);
my @kids;
- my $h = BeginEnumWindows shift;
+ my $h = BeginEnumWindows(@_ ? shift : 1); # HWND_DESKTOP
my $w;
push @kids, $w while $w = GetNextWindow $h;
EndEnumWindows $h;
Similar to change_entry(), but takes a hash reference as an argument.
+=item process_hwnd()
+
+returns the C<owner_hwnd> of the process entry (for VIO windowed processes
+this is the frame window of the session).
+
=item Title()
-returns a title of the current session. (There is no way to get this
-info in non-standard Session Managers, this implementation is a
-shortcut via process_entry().)
+returns the text of the task switch menu entry of the current session.
+(There is no way to get this info in non-standard Session Managers. This
+implementation is a shortcut via process_entry().)
=item C<Title_set(newtitle)>
help 372
for a funny - and wrong - explanation ;-). In such cases a
-direct-manipulation of low-level entries is used. Keep in mind that
-some versions of OS/2 leak memory with such a manipulation.
+direct-manipulation of low-level entries is used (same as bothTitle_set()).
+Keep in mind that some versions of OS/2 leak memory with such a manipulation.
+
+=item winTitle()
+
+returns text of the titlebar of the current process' window.
+
+=item C<winTitle_set(newtitle)>
+
+sets text of the titlebar of the current process' window. The change does not
+affect the text of the switch entry of the current window.
+
+=item C<swTitle_set(newtitle)>
+
+sets text of the task switch menu entry of the current process' window. [There
+is no API to query this title.] Does it via SwitchEntry interface,
+not Session manager interface. The change does not affect the text of the
+titlebar of the current window.
+
+=item C<bothTitle_set(newtitle)>
+
+sets text of the titlebar and task switch menu of the current process' window
+via direct manipulation of the windows' texts.
=item C<SwitchToProgram($sw_entry)>
the same thread as the owned thread, so they engage in the same
message queue.]
-Windows may be in many different state: Focused, Activated (=Windows
-in the I<parent/child> tree between the root and the window with
-focus; usually indicate such "active state" by titlebar highlights),
-Enabled/Disabled (this influences *an ability* to receive user input
-(be focused?), and may change appearance, as for enabled/disabled
-buttons), Visible/Hidden, Minimized/Maximized/Restored, Modal, etc.
+Windows may be in many different state: Focused (take keyboard events) or not,
+Activated (=Frame windows in the I<parent/child> tree between the root and
+the window with the focus; usually indicate such "active state" by titlebar
+highlights, and take mouse events) or not, Enabled/Disabled (this influences
+the ability to update the graphic, and may change appearance, as for
+enabled/disabled buttons), Visible/Hidden, Minimized/Maximized/Restored, Modal
+or not, etc.
+
+The APIs below all die() on error with the message being $^E.
=over
=item C<WindowText($hwnd)>
-gets "a text content" of a window.
+gets "a text content" of a window. Requires (morphing to) PM.
=item C<WindowText_set($hwnd, $text)>
-sets "a text content" of a window.
+sets "a text content" of a window. Requires (morphing to) PM.
-=item C<WindowPos($hwnd)>
+=item C<($x, $y, $flags, $width, $height, $behind, @rest) = WindowPos($hwnd)>
gets window position info as 8 integers (of C<SWP>), in the order suitable
-for WindowPos_set(): $x, $y, $fl, $w, $h, $behind, @rest.
+for WindowPos_set(). @rest is marked as "reserved" in PM docs. $flags
+is a combination of C<SWP_*> constants.
+
+=item C<$hash = hWindowPos($hwnd)>
+
+gets window position info as a hash reference; the keys are C<flags width
+height x y behind hwnd reserved1 reserved2>.
-=item C<WindowPos_set($hwnd, $x, $y, $flags = SWP_MOVE, $wid = 0, $h = 0, $behind = HWND_TOP)>
+Example:
+
+ exit unless $hash->{flags} & SWP_MAXIMIZE; # Maximized
+
+=item C<WindowPos_set($hwnd, $x, $y, $flags = SWP_MOVE, $width = 0, $height = 0, $behind = HWND_TOP)>
Set state of the window: position, size, zorder, show/hide, activation,
minimize/maximize/restore etc. Which of these operations to perform
is governed by $flags.
-=item C<WindowProcess($hwnd)>
+=item C<hWindowPos_set($hash, [$hwnd])>
-gets I<PID> and I<TID> of the process associated to the window.
+Same as C<WindowPos_set>, but takes the position from keys C<fl width height
+x y behind hwnd> of the hash referenced by $hash. If $hwnd is explicitly
+specified, it overrides C<$hash->{hwnd}>. If $hash->{flags} is not specified,
+it is calculated basing on the existing keys of $hash. Requires (morphing to) PM.
-=item ActiveWindow([$parentHwnd])
+Example:
-gets the active subwindow's handle for $parentHwnd or desktop.
-Returns FALSE if none.
+ hWindowPos_set {flags => SWP_MAXIMIZE}, $hwnd; # Maximize
+
+=item C<($pid, $tid) = WindowProcess($hwnd)>
+
+gets I<PID> and I<TID> of the process associated to the window.
=item C<ClassName($hwnd)>
=item FocusWindow()
-returns the handle of the focus window. Optional argument for specifying the desktop
-to use.
+returns the handle of the focus window. Optional argument for specifying
+the desktop to use.
=item C<FocusWindow_set($hwnd)>
set the focus window by handle. Optional argument for specifying the desktop
to use. E.g, the first entry in program_entries() is the C<Ctrl-Esc> list.
-To show it
+To show an application, use either one of
- WinShowWindow( wlhwnd, TRUE );
- WinSetFocus( HWND_DESKTOP, wlhwnd );
- WinSwitchToProgram(wlhswitch);
+ WinShowWindow( $hwnd, 1 );
+ SetFocus( $hwnd );
+ SwitchToProgram($switch_handle);
+(Which work with alternative focus-to-front policies?) Requires (morphing to) PM.
+
+=item C<ActiveWindow([$parentHwnd])>
+
+gets the active subwindow's handle for $parentHwnd or desktop.
+Returns FALSE if none.
+
+=item C<ActiveWindow_set($hwnd, [$parentHwnd])>
+
+sets the active subwindow's handle for $parentHwnd or desktop. Requires (morphing to) PM.
=item C<ShowWindow($hwnd [, $show])>
Set visible/hidden flag of the window. Default: $show is TRUE.
+=item C<EnableWindowUpdate($hwnd [, $update])>
+
+Set window visibility state flag for the window for subsequent drawing.
+No actual drawing is done at this moment. Use C<ShowWindow($hwnd, $state)>
+when redrawing is needed. While update is disabled, changes to the "window
+state" do not change the appearence of the window. Default: $update is TRUE.
+
+(What is manipulated is the bit C<WS_VISIBLE> of the window style.)
+
+=item C<EnableWindow($hwnd [, $enable])>
+
+Set the window enabled state. Default: $enable is TRUE.
+
+Results in C<WM_ENABLED> message sent to the window. Typically, this
+would change the appearence of the window. If at the moment of disabling
+focus is in the window (or a descendant), focus is lost (no focus anywhere).
+If focus is needed, it can be reassigned explicitly later.
+
+=item IsWindowEnabled(), IsWindowVisible(), IsWindowShowing()
+
+these functions take $hwnd as an argument. IsWindowEnabled() queries
+the state changed by EnableWindow(), IsWindowVisible() the state changed
+by ShowWindow(), IsWindowShowing() is true if there is a part of the window
+visible on the screen.
+
=item C<PostMsg($hwnd, $msg, $mp1, $mp2)>
post message to a window. The meaning of $mp1, $mp2 is specific for each
-message id $msg, they default to 0. E.g., in C it is done similar to
+message id $msg, they default to 0. E.g.,
+
+ use OS2::Process qw(:DEFAULT WM_SYSCOMMAND WM_CONTEXTMENU
+ WM_SAVEAPPLICATION WM_QUIT WM_CLOSE
+ SC_MAXIMIZE SC_RESTORE);
+ $hwnd = process_hentry()->{owner_hwnd};
+ # Emulate choosing `Restore' from the window menu:
+ PostMsg $hwnd, WM_SYSCOMMAND, MPFROMSHORT(SC_RESTORE); # Not immediate
+
+ # Emulate `Show-Contextmenu' (Double-Click-2), two ways:
+ PostMsg ActiveWindow, WM_CONTEXTMENU;
+ PostMsg FocusWindow, WM_CONTEXTMENU;
+
+ /* Emulate `Close' */
+ PostMsg ActiveWindow, WM_CLOSE;
+
+ /* Same but with some "warnings" to the application */
+ $hwnd = ActiveWindow;
+ PostMsg $hwnd, WM_SAVEAPPLICATION;
+ PostMsg $hwnd, WM_CLOSE;
+ PostMsg $hwnd, WM_QUIT;
- /* Emulate `Restore' */
- WinPostMsg(SwitchBlock.tswe[i].swctl.hwnd, WM_SYSCOMMAND,
- MPFROMSHORT(SC_RESTORE), 0);
+In fact, MPFROMSHORT() may be omited above.
- /* Emulate `Show-Contextmenu' (Double-Click-2) */
- hwndParent = WinQueryFocus(HWND_DESKTOP);
- hwndActive = WinQueryActiveWindow(hwndParent);
- WinPostMsg(hwndActive, WM_CONTEXTMENU, MPFROM2SHORT(0,0), MPFROMLONG(0));
+For messages to other processes, messages which take/return a pointer are
+not supported.
- /* Emulate `Close' */
- WinPostMsg(pSWB->aswentry[i].swctl.hwnd, WM_CLOSE, 0, 0);
+=item C<MP*()>
- /* Same but softer: */
- WinPostMsg(hwndactive, WM_SAVEAPPLICATION, 0L, 0L);
- WinPostMsg(hwndactive, WM_CLOSE, 0L, 0L));
- WinPostMsg(hwndactive, WM_QUIT, 0L, 0L));
+The functions MPFROMSHORT(), MPVOID(), MPFROMCHAR(), MPFROM2SHORT(),
+MPFROMSH2CH(), MPFROMLONG() can be used the same way as from C. Use them
+to construct parameters $m1, $m2 to PostMsg().
+
+These functions are not exported by default.
=item C<$eh = BeginEnumWindows($hwnd)>
starts enumerating immediate child windows of $hwnd in z-order. The
enumeration reflects the state at the moment of BeginEnumWindows() calls;
-use IsWindow() to be sure.
+use IsWindow() to be sure. All the functions in this group require (morphing to) PM.
=item C<$kid_hwnd = GetNextWindow($eh)>
End enumeration and release the list.
-=item C<@list = ChildWindows($hwnd)>
+=item C<@list = ChildWindows([$hwnd])>
returns the list of child windows at the moment of the call. Same remark
-as for enumeration interface applies. Example of usage:
+as for enumeration interface applies. Defaults to HWND_DESKTOP.
+Example of usage:
sub l {
my ($o,$h) = @_;
=item C<WindowFromPoint($x, $y [, $hwndParent [, $descedantsToo]])>
gets a handle of a child of $hwndParent at C<($x,$y)>. If $descedantsToo
-(defaulting to 0) then children of children may be returned too. May return
+(defaulting to 1) then children of children may be returned too. May return
$hwndParent (defaults to desktop) if no suitable children are found,
or 0 if the point is outside the parent.
=back
+=item ResetWinError()
+
+Resets $^E. One may need to call it before the C<Win*>-class APIs which may
+return 0 during normal operation. In such a case one should check both
+for return value being zero and $^E being non-zero. The following APIs
+do ResetWinError() themselves, thus do not need an explicit one:
+
+ WindowPtr
+ WindowULong
+ WindowUShort
+ WindowTextLength
+ ActiveWindow
+ PostMsg
+
+This function is normally not needed. Not exported by default.
+
=back
=head1 OS2::localMorphPM class
-This class morphs the process to PM for the duration of the given context.
+This class morphs the process to PM for the duration of the given scope.
{
my $h = OS2::localMorphPM->new(0);
=head1 TODO
-Constants (currently one needs to get them looking in a header file):
+Add tests for:
- HWND_*
- WM_* /* Separate module? */
- SC_*
- SWP_*
- WC_*
- PROG_*
- QW_*
- EDI_*
- WS_*
+ SwitchToProgram
+ ClassName
+ out_codepage
+ out_codepage_set
+ in_codepage
+ in_codepage_set
+ cursor
+ cursor_set
+ screen
+ screen_set
+ process_codepages
+ QueryWindow
+ EnumDlgItem
+ WindowPtr
+ WindowULong
+ WindowUShort
+ SetWindowBits
+ SetWindowPtr
+ SetWindowULong
+ SetWindowUShort
+ my_type
+ file_type
+ scrsize
+ scrsize_set
+
+Document:
+Query/SetWindowULong/Short/Ptr, SetWindowBits.
+
+Implement InvalidateRect,
+CreateFrameControl. ClipbrdFmtInfo, ClipbrdData, OpenClipbrd, CloseClipbrd,
+ClipbrdData_set, EnumClipbrdFmt, EmptyClipbrd. SOMETHINGFROMMR.
+
+
+ >But I wish to change the default button if the user enters some
+ >text into an entryfield. I can detect the entry ok, but can't
+ >seem to get the button to change to default.
+ >
+ >No matter what message I send it, it's being ignored.
+
+ You need to get the style of the buttons using WinQueryWindowULong/QWL_STYLE,
+ set and reset the BS_DEFAULT bits as appropriate and then use
+ WinSetWindowULong/QWL_STYLE to set the button style.
+ Something like this:
+ hwnd1 = WinWindowFromID (hwnd, id1);
+ hwnd2 = WinWindowFromID (hwnd, id2);
+ style1 = WinQueryWindowULong (hwnd1, QWL_STYLE);
+ style2 = WinQueryWindowULong (hwnd2, QWL_STYLE);
+ style1 |= style2 & BS_DEFAULT;
+ style2 &= ~BS_DEFAULT;
+ WinSetWindowULong (hwnd1, QWL_STYLE, style1);
+ WinSetWindowULong (hwnd2, QWL_STYLE, style2);
+
+ > How to do query and change a frame creation flags for existing window?
+
+ Set the style bits that correspond to the FCF_* flag for the frame
+ window and then send a WM_UPDATEFRAME message with the appropriate FCF_*
+ flag in mp1.
+
+ ULONG ulFrameStyle;
+ ulFrameStyle = WinQueryWindowULong( WinQueryWindow(hwnd, QW_PARENT),
+ QWL_STYLE );
+ ulFrameStyle = (ulFrameStyle & ~FS_SIZEBORDER) | FS_BORDER;
+ WinSetWindowULong( WinQueryWindow(hwnd, QW_PARENT),
+ QWL_STYLE,
+ ulFrameStyle );
+ WinSendMsg( WinQueryWindow(hwnd, QW_PARENT),
+ WM_UPDATEFRAME,
+ MPFROMP(FCF_SIZEBORDER),
+ MPVOID );
+
+ If the FCF_* flags you want to change does not have a corresponding FS_*
+ style (i.e. the FCF_* flag corresponds to the presence/lack of a frame
+ control rather than a property of the frame itself) then you create or
+ destroy the appropriate control window using the correct FID_* window
+ identifier and then send the WM_UPDATEFRAME message with the appropriate
+ FCF_* flag in mp1.
+
+ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*
+ | SetFrameBorder() |
+ | Changes a frame window's border to the requested type. |
+ | |
+ | Parameters on entry: |
+ | hwndFrame -> Frame window whose border is to be changed. |
+ | ulBorderStyle -> Type of border to change to. |
+ | |
+ | Returns: |
+ | BOOL -> Success indicator. |
+ | |
+ * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -*/
+ BOOL SetFrameBorder( HWND hwndFrame, ULONG ulBorderType ) {
+ ULONG ulFrameStyle;
+ BOOL fSuccess = TRUE;
+
+ ulFrameStyle = WinQueryWindowULong( hwndFrame, QWL_STYLE );
+
+ switch ( ulBorderType ) {
+ case FS_SIZEBORDER :
+ ulFrameStyle = (ulFrameStyle & ~(FS_DLGBORDER | FS_BORDER))
+ | FS_SIZEBORDER;
+ break;
+
+ case FS_DLGBORDER :
+ ulFrameStyle = (ulFrameStyle & ~(FS_SIZEBORDER | FS_BORDER))
+ | FS_DLGBORDER;
+ break;
+
+ case FS_BORDER :
+ ulFrameStyle = (ulFrameStyle & ~(FS_SIZEBORDER | FS_DLGBORDER))
+ | FS_BORDER;
+ break;
+
+ default :
+ fSuccess = FALSE;
+ break;
+ } // end switch
+
+ if ( fSuccess ) {
+ fSuccess = WinSetWindowULong( hwndFrame, QWL_STYLE, ulFrameStyle );
+
+ if ( fSuccess ) {
+ fSuccess = (BOOL)WinSendMsg( hwndFrame, WM_UPDATEFRAME, 0, 0 );
+ if ( fSuccess )
+ fSuccess = WinInvalidateRect( hwndFrame, NULL, TRUE );
+ }
+ }
+
+ return ( fSuccess );
+
+ } // End SetFrameBorder()
+
+ hwndMenu=WinLoadMenu(hwndParent,NULL,WND_IMAGE);
+ WinSetWindowUShort(hwndMenu,QWS_ID,FID_MENU);
+ ulStyle=WinQueryWindowULong(hwndMenu,QWL_STYLE);
+ WinSetWindowULong(hwndMenu,QWL_STYLE,ulStyle|MS_ACTIONBAR);
+ WinSendMsg(hwndParent,WM_UPDATEFRAME,MPFROMSHORT(FCF_MENU),0L);
+
+ OS/2-windows have another "parent" called the *owner*,
+ which must be set separately - to get a close relationship:
+
+ WinSetOwner (hwndFrameChild, hwndFrameMain);
+
+ Now your child should move with your main window!
+ And always stays on top of it....
+
+ To avoid this, for example for dialogwindows, you can
+ also "disconnect" this relationship with:
+
+ WinSetWindowBits (hwndFrameChild, QWL_STYLE
+ , FS_NOMOVEWITHOWNER
+ , FS_NOMOVEWITHOWNER);
+
+ Adding a button icon later:
+
+ /* switch the button style to BS_MINIICON */
+ WinSetWindowBits(hwndBtn, QWL_STYLE, BS_MINIICON, BS_MINIICON) ;
+
+ /* set up button control data */
+ BTNCDATA bcd;
+ bcd.cb = sizeof(BTNCDATA);
+ bcd.hImage = WinLoadPointer(HWND_DESKTOP, dllHandle, ID_ICON_BUTTON1) ;
+ bcd.fsCheckState = bcd.fsHiliteState = 0 ;
+
+
+ WNDPARAMS wp;
+ wp.fsStatus = WPM_CTLDATA;
+ wp.pCtlData = &bcd;
+
+ /* add the icon on the button */
+ WinSendMsg(hwndBtn, WM_SETWINDOWPARAMS, (MPARAM)&wp, NULL);
-Show/Hide, Enable/Disable (WinShowWindow(), WinIsWindowVisible(),
-WinEnableWindow(), WinIsWindowEnabled()).
+ MO> Can anyone tell what OS/2 expects of an application to be properly
+ MO> minimized to the desktop?
+ case WM MINMAXFRAME :
+ {
+ BOOL fShow = ! (((PSWP) mp1)->fl & SWP MINIMIZE);
+ HENUM henum;
-Maximize/minimize/restore via WindowPos_set(), check via checking
-WS_MAXIMIZED/WS_MINIMIZED flags (how to get them?).
+ HWND hwndChild;
+
+ WinEnableWindowUpdate ( hwnd, FALSE );
+
+ for (henum=WinBeginEnumWindows(hwnd);
+ (hwndChild = WinGetNextWindow (henum)) != 0; )
+ WinShowWindow ( hwndChild, fShow );
+
+ WinEndEnumWindows ( henum );
+ WinEnableWindowUpdate ( hwnd, TRUE );
+ }
+ break;
+
+Why C<hWindowPos DesktopWindow> gives C<< behind => HWND_TOP >>?
=head1 $^E
distinguish failure from a "normal" 0-return. In such cases C<$^E ==
0> indicates an absence of error.
+=head1 EXPORTS
+
+In addition to symbols described above, the following constants (available
+also via module C<OS2::Process::Const>) are exportable. Note that these
+symbols live in package C<OS2::Process::Const>, they are not available
+by full name through C<OS2::Process>!
+
+ HWND_* Standard (abstract) window handles
+ WM_* Message ids
+ SC_* WM_SYSCOMMAND flavor
+ SWP_* Size/move etc flag
+ WC_* Standard window classes
+ PROG_* Program category (PM, VIO etc)
+ QW_* Query-Window flag
+ EDI_* Enumerate-Dialog-Item code
+ WS_* Window Style flag
+ QWS_* Query-window-UShort offsets
+ QWP_* Query-window-pointer offsets
+ QWL_* Query-window-ULong offsets
+ FF_* Frame-window state flags
+ FI_* Frame-window information flags
+ LS_* List box styles
+ FS_* Frame style
+ FCF_* Frame creation flags
+ BS_* Button style
+ MS_* Menu style
+ TBM_* Title bar messages?
+ CF_* Clipboard formats
+ CFI_* Clipboard storage type
+ FID_* ids of subwindows of frames
+
=head1 BUGS
whether a given API dies or returns FALSE/empty-list on error may be
return apptype;
}
+/* These use different type of wrapper. Good to check wrappers. ;-) */
+/* XXXX This assumes DOS type return type, without SEVERITY?! */
DeclFuncByORD(HSWITCH, myWinQuerySwitchHandle, ORD_WinQuerySwitchHandle,
(HWND hwnd, PID pid), (hwnd, pid))
DeclFuncByORD(ULONG, myWinQuerySwitchEntry, ORD_WinQuerySwitchEntry,
(HWND hwnd, char* text), (hwnd, text))
DeclFuncByORD(BOOL, myWinQueryWindowProcess, ORD_WinQueryWindowProcess,
(HWND hwnd, PPID ppid, PTID ptid), (hwnd, ppid, ptid))
-
DeclFuncByORD(ULONG, XmyWinSwitchToProgram, ORD_WinSwitchToProgram,
(HSWITCH hsw), (hsw))
#define myWinSwitchToProgram(hsw) (!CheckOSError(XmyWinSwitchToProgram(hsw)))
-DeclFuncByORD(HWND, myWinQueryActiveWindow, ORD_WinQueryActiveWindow,
- (HWND hwnd), (hwnd))
+DeclWinFunc_CACHE(HWND, QueryWindow, (HWND hwnd, LONG cmd), (hwnd, cmd))
+DeclWinFunc_CACHE(BOOL, QueryWindowPos, (HWND hwnd, PSWP pswp),
+ (hwnd, pswp))
+DeclWinFunc_CACHE(LONG, QueryWindowText,
+ (HWND hwnd, LONG cchBufferMax, PCH pchBuffer),
+ (hwnd, cchBufferMax, pchBuffer))
+DeclWinFunc_CACHE(LONG, QueryClassName, (HWND hwnd, LONG cchMax, PCH pch),
+ (hwnd, cchMax, pch))
+DeclWinFunc_CACHE(HWND, QueryFocus, (HWND hwndDesktop), (hwndDesktop))
+DeclWinFunc_CACHE(BOOL, SetFocus, (HWND hwndDesktop, HWND hwndFocus),
+ (hwndDesktop, hwndFocus))
+DeclWinFunc_CACHE(BOOL, ShowWindow, (HWND hwnd, BOOL fShow), (hwnd, fShow))
+DeclWinFunc_CACHE(BOOL, EnableWindow, (HWND hwnd, BOOL fEnable),
+ (hwnd, fEnable))
+DeclWinFunc_CACHE(BOOL, SetWindowPos,
+ (HWND hwnd, HWND hwndInsertBehind, LONG x, LONG y,
+ LONG cx, LONG cy, ULONG fl),
+ (hwnd, hwndInsertBehind, x, y, cx, cy, fl))
+DeclWinFunc_CACHE(HENUM, BeginEnumWindows, (HWND hwnd), (hwnd))
+DeclWinFunc_CACHE(BOOL, EndEnumWindows, (HENUM henum), (henum))
+DeclWinFunc_CACHE(BOOL, EnableWindowUpdate, (HWND hwnd, BOOL fEnable),
+ (hwnd, fEnable))
+DeclWinFunc_CACHE(BOOL, SetWindowBits,
+ (HWND hwnd, LONG index, ULONG flData, ULONG flMask),
+ (hwnd, index, flData, flMask))
+DeclWinFunc_CACHE(BOOL, SetWindowPtr, (HWND hwnd, LONG index, PVOID p),
+ (hwnd, index, p))
+DeclWinFunc_CACHE(BOOL, SetWindowULong, (HWND hwnd, LONG index, ULONG ul),
+ (hwnd, index, ul))
+DeclWinFunc_CACHE(BOOL, SetWindowUShort, (HWND hwnd, LONG index, USHORT us),
+ (hwnd, index, us))
+DeclWinFunc_CACHE(HWND, IsChild, (HWND hwnd, HWND hwndParent),
+ (hwnd, hwndParent))
+DeclWinFunc_CACHE(HWND, WindowFromId, (HWND hwnd, ULONG id), (hwnd, id))
+DeclWinFunc_CACHE(HWND, EnumDlgItem, (HWND hwndDlg, HWND hwnd, ULONG code),
+ (hwndDlg, hwnd, code))
+DeclWinFunc_CACHE(HWND, QueryDesktopWindow, (HAB hab, HDC hdc), (hab, hdc));
+DeclWinFunc_CACHE(BOOL, SetActiveWindow, (HWND hwndDesktop, HWND hwnd),
+ (hwndDesktop, hwnd));
+
+/* These functions may return 0 on success; check $^E/Perl_rc on res==0: */
+DeclWinFunc_CACHE_resetError(PVOID, QueryWindowPtr, (HWND hwnd, LONG index),
+ (hwnd, index))
+DeclWinFunc_CACHE_resetError(ULONG, QueryWindowULong, (HWND hwnd, LONG index),
+ (hwnd, index))
+DeclWinFunc_CACHE_resetError(SHORT, QueryWindowUShort, (HWND hwnd, LONG index),
+ (hwnd, index))
+DeclWinFunc_CACHE_resetError(LONG, QueryWindowTextLength, (HWND hwnd), (hwnd))
+DeclWinFunc_CACHE_resetError(HWND, QueryActiveWindow, (HWND hwnd), (hwnd))
+DeclWinFunc_CACHE_resetError(BOOL, PostMsg,
+ (HWND hwnd, ULONG msg, MPARAM mp1, MPARAM mp2),
+ (hwnd, msg, mp1, mp2))
+DeclWinFunc_CACHE_resetError(HWND, GetNextWindow, (HENUM henum), (henum))
+DeclWinFunc_CACHE_resetError(BOOL, IsWindowEnabled, (HWND hwnd), (hwnd))
+DeclWinFunc_CACHE_resetError(BOOL, IsWindowVisible, (HWND hwnd), (hwnd))
+DeclWinFunc_CACHE_resetError(BOOL, IsWindowShowing, (HWND hwnd), (hwnd))
+
+/* No die()ing on error */
+DeclWinFunc_CACHE_survive(BOOL, IsWindow, (HAB hab, HWND hwnd), (hab, hwnd))
+
+/* These functions are called frow complicated wrappers: */
ULONG (*pWinQuerySwitchList) (HAB hab, PSWBLOCK pswblk, ULONG usDataLength);
ULONG (*pWinChangeSwitchEntry) (HSWITCH hsw, __const__ SWCNTRL *pswctl);
-
-HWND (*pWinQueryWindow) (HWND hwnd, LONG cmd);
-BOOL (*pWinQueryWindowPos) (HWND hwnd, PSWP pswp);
-LONG (*pWinQueryWindowText) (HWND hwnd, LONG cchBufferMax, PCH pchBuffer);
-LONG (*pWinQueryWindowTextLength) (HWND hwnd);
-LONG (*pWinQueryClassName) (HWND hwnd, LONG cchMax, PCH pch);
-HWND (*pWinQueryFocus) (HWND hwndDesktop);
-BOOL (*pWinSetFocus) (HWND hwndDesktop, HWND hwndFocus);
-BOOL (*pWinShowWindow) (HWND hwnd, BOOL fShow);
-BOOL (*pWinPostMsg) (HWND hwnd, ULONG msg, MPARAM mp1, MPARAM mp2);
-BOOL (*pWinSetWindowPos) (HWND hwnd, HWND hwndInsertBehind, LONG x, LONG y,
- LONG cx, LONG cy, ULONG fl);
-HENUM (*pWinBeginEnumWindows) (HWND hwnd);
-BOOL (*pWinEndEnumWindows) (HENUM henum);
-HWND (*pWinGetNextWindow) (HENUM henum);
-BOOL (*pWinIsWindow) (HAB hab, HWND hwnd);
-HWND (*pWinQueryWindow) (HWND hwnd, LONG cmd);
-
-DeclWinFuncByORD(HWND, IsChild, ORD_WinIsChild,
- (HWND hwnd, HWND hwndParent), (hwnd, hwndParent))
-DeclWinFuncByORD(HWND, WindowFromId, ORD_WinWindowFromId,
- (HWND hwnd, ULONG id), (hwnd, id))
-
HWND (*pWinWindowFromPoint)(HWND hwnd, __const__ POINTL *pptl, BOOL fChildren);
-DeclWinFuncByORD(HWND, EnumDlgItem, ORD_WinEnumDlgItem,
- (HWND hwndDlg, HWND hwnd, ULONG code), (hwndDlg, hwnd, code));
+
+/* These functions have different names/signatures than what is
+ declared above */
+#define QueryFocusWindow QueryFocus
+#define FocusWindow_set(hwndFocus, hwndDesktop) SetFocus(hwndDesktop, hwndFocus)
+#define WindowPos_set(hwnd, x, y, fl, cx, cy, hwndInsertBehind) \
+ SetWindowPos(hwnd, hwndInsertBehind, x, y, cx, cy, fl)
+#define myWinQueryWindowPtr(hwnd, i) ((ULONG)QueryWindowPtr(hwnd, i))
int
WindowText_set(HWND hwnd, char* text)
return !CheckWinError(myWinSetWindowText(hwnd, text));
}
-LONG
-QueryWindowTextLength(HWND hwnd)
-{
- LONG ret;
-
- if (!pWinQueryWindowTextLength)
- AssignFuncPByORD(pWinQueryWindowTextLength, ORD_WinQueryWindowTextLength);
- ret = pWinQueryWindowTextLength(hwnd);
- CheckWinError(ret); /* May put false positive */
- return ret;
-}
-
SV *
-QueryWindowText(HWND hwnd)
+myQueryWindowText(HWND hwnd)
{
- LONG l = QueryWindowTextLength(hwnd);
- SV *sv = newSVpvn("", 0);
+ LONG l = QueryWindowTextLength(hwnd), len;
+ SV *sv;
STRLEN n_a;
- if (l == 0)
- return sv;
+ if (l == 0) {
+ if (Perl_rc) /* Last error */
+ return &PL_sv_undef;
+ return &PL_sv_no;
+ }
+ sv = newSVpvn("", 0);
SvGROW(sv, l + 1);
- if (!pWinQueryWindowText)
- AssignFuncPByORD(pWinQueryWindowText, ORD_WinQueryWindowText);
- CheckWinError(l = pWinQueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a)));
+ len = WinQueryWindowText(hwnd, l + 1, SvPV_force(sv, n_a));
+ if (len != l) {
+ Safefree(sv);
+ croak("WinQueryWindowText() uncompatible with WinQueryWindowTextLength()");
+ }
SvCUR_set(sv, l);
return sv;
}
{
SWP swp;
- if (!pWinQueryWindowPos)
- AssignFuncPByORD(pWinQueryWindowPos, ORD_WinQueryWindowPos);
- if (CheckWinError(pWinQueryWindowPos(hwnd, &swp)))
+ if (!QueryWindowPos(hwnd, &swp))
croak("WinQueryWindowPos() error");
return swp;
}
}
SV *
-QueryClassName(HWND hwnd)
+myQueryClassName(HWND hwnd)
{
SV *sv = newSVpvn("",0);
STRLEN l = 46, len = 0, n_a;
- if (!pWinQueryClassName)
- AssignFuncPByORD(pWinQueryClassName, ORD_WinQueryClassName);
while (l + 1 >= len) {
if (len)
len = 2*len + 10; /* Grow quick */
else
len = l + 2;
SvGROW(sv, len);
- l = pWinQueryClassName(hwnd, len, SvPV_force(sv, n_a));
- CheckWinError(l);
- SvCUR_set(sv, l);
+ l = QueryClassName(hwnd, len, SvPV_force(sv, n_a));
}
+ SvCUR_set(sv, l);
return sv;
}
HWND
-QueryFocusWindow(HWND hwndDesktop)
-{
- HWND ret;
-
- if (!pWinQueryFocus)
- AssignFuncPByORD(pWinQueryFocus, ORD_WinQueryFocus);
- ret = pWinQueryFocus(hwndDesktop);
- CheckWinError(ret);
- return ret;
-}
-
-BOOL
-FocusWindow_set(HWND hwndFocus, HWND hwndDesktop)
-{
- if (!pWinSetFocus)
- AssignFuncPByORD(pWinSetFocus, ORD_WinSetFocus);
- return !CheckWinError(pWinSetFocus(hwndDesktop, hwndFocus));
-}
-
-BOOL
-ShowWindow(HWND hwnd, BOOL fShow)
-{
- if (!pWinShowWindow)
- AssignFuncPByORD(pWinShowWindow, ORD_WinShowWindow);
- return !CheckWinError(pWinShowWindow(hwnd, fShow));
-}
-
-BOOL
-PostMsg(HWND hwnd, ULONG msg, ULONG mp1, ULONG mp2)
-{
- if (!pWinPostMsg)
- AssignFuncPByORD(pWinPostMsg, ORD_WinPostMsg);
- return !CheckWinError(pWinPostMsg(hwnd, msg, (MPARAM)mp1, (MPARAM)mp2));
-}
-
-BOOL
-WindowPos_set(HWND hwnd, LONG x, LONG y, ULONG fl, LONG cx, LONG cy,
- HWND hwndInsertBehind)
-{
- if (!pWinSetWindowPos)
- AssignFuncPByORD(pWinSetWindowPos, ORD_WinSetWindowPos);
- return !CheckWinError(pWinSetWindowPos(hwnd, hwndInsertBehind, x, y, cx, cy, fl));
-}
-
-HENUM
-BeginEnumWindows(HWND hwnd)
-{
- if (!pWinBeginEnumWindows)
- AssignFuncPByORD(pWinBeginEnumWindows, ORD_WinBeginEnumWindows);
- return SaveWinError(pWinBeginEnumWindows(hwnd));
-}
-
-BOOL
-EndEnumWindows(HENUM henum)
-{
- if (!pWinEndEnumWindows)
- AssignFuncPByORD(pWinEndEnumWindows, ORD_WinEndEnumWindows);
- return !CheckWinError(pWinEndEnumWindows(henum));
-}
-
-HWND
-GetNextWindow(HENUM henum)
-{
- if (!pWinGetNextWindow)
- AssignFuncPByORD(pWinGetNextWindow, ORD_WinGetNextWindow);
- return SaveWinError(pWinGetNextWindow(henum));
-}
-
-BOOL
-IsWindow(HWND hwnd, HAB hab)
-{
- if (!pWinIsWindow)
- AssignFuncPByORD(pWinIsWindow, ORD_WinIsWindow);
- return !CheckWinError(pWinIsWindow(hab, hwnd));
-}
-
-HWND
-QueryWindow(HWND hwnd, LONG cmd)
-{
- if (!pWinQueryWindow)
- AssignFuncPByORD(pWinQueryWindow, ORD_WinQueryWindow);
- return !CheckWinError(pWinQueryWindow(hwnd, cmd));
-}
-
-HWND
WindowFromPoint(long x, long y, HWND hwnd, BOOL fChildren)
{
POINTL ppl;
croak("switch_entry not implemented on DOS"); /* not OS/2. */
if (CheckWinError(hSwitch =
myWinQuerySwitchHandle(hwnd, pid)))
- croak("WinQuerySwitchHandle err %ld", Perl_rc);
+ croak("WinQuerySwitchHandle: %s", os2error(Perl_rc));
swentryp->hswitch = hSwitch;
if (CheckOSError(myWinQuerySwitchEntry(hSwitch, &swentryp->swctl)))
croak("WinQuerySwitchEntry err %ld", rc);
return sid;
}
+#define ulMPFROMSHORT(i) ((unsigned long)MPFROMSHORT(i))
+#define ulMPVOID() ((unsigned long)MPVOID)
+#define ulMPFROMCHAR(i) ((unsigned long)MPFROMCHAR(i))
+#define ulMPFROM2SHORT(x1,x2) ((unsigned long)MPFROM2SHORT(x1,x2))
+#define ulMPFROMSH2CH(s, c1, c2) ((unsigned long)MPFROMSH2CH(s, c1, c2))
+#define ulMPFROMLONG(x) ((unsigned long)MPFROMLONG(x))
+
MODULE = OS2::Process PACKAGE = OS2::Process
+PROTOTYPES: ENABLE
unsigned long
constant(name,arg)
SV *
create_swentry( char *title, unsigned long sw_hwnd, unsigned long icon_hwnd, unsigned long owner_phandle, unsigned long owner_pid, unsigned long owner_sid, unsigned long visible, unsigned long switchable, unsigned long jumpable, unsigned long ptype, unsigned long sw_entry)
+PROTOTYPE: DISABLE
int
change_swentry( SV *sv )
SV *
process_swentry(unsigned long pid = getpid(), unsigned long hwnd = NULLHANDLE);
+ PROTOTYPE: DISABLE
int
swentry_size()
SV *
swentries_list()
+void
+ResetWinError()
+
int
WindowText_set(unsigned long hwndFrame, char *title)
ShowWindow(unsigned long hwnd, bool fShow = TRUE)
bool
+EnableWindow(unsigned long hwnd, bool fEnable = TRUE)
+
+bool
PostMsg(unsigned long hwnd, unsigned long msg, unsigned long mp1 = 0, unsigned long mp2 = 0)
+ C_ARGS: hwnd, msg, (MPARAM)mp1, (MPARAM)mp2
bool
WindowPos_set(unsigned long hwnd, long x, long y, unsigned long fl = SWP_MOVE, long cx = 0, long cy = 0, unsigned long hwndInsertBehind = HWND_TOP)
+ PROTOTYPE: DISABLE
unsigned long
BeginEnumWindows(unsigned long hwnd)
GetNextWindow(unsigned long henum)
bool
-IsWindow(unsigned long hwnd, unsigned long hab = Acquire_hab())
+IsWindowVisible(unsigned long hwnd)
+
+bool
+IsWindowEnabled(unsigned long hwnd)
+
+bool
+IsWindowShowing(unsigned long hwnd)
unsigned long
QueryWindow(unsigned long hwnd, long cmd)
WindowFromId(unsigned long hwndParent, unsigned long id)
unsigned long
-WindowFromPoint(long x, long y, unsigned long hwnd, bool fChildren = 0)
+WindowFromPoint(long x, long y, unsigned long hwnd = HWND_DESKTOP, bool fChildren = TRUE)
+PROTOTYPE: DISABLE
unsigned long
EnumDlgItem(unsigned long hwndDlg, unsigned long code, unsigned long hwnd = NULLHANDLE)
C_ARGS: hwndDlg, hwnd, code
+bool
+EnableWindowUpdate(unsigned long hwnd, bool fEnable = TRUE)
+
+bool
+SetWindowBits(unsigned long hwnd, long index, unsigned long flData, unsigned long flMask)
+
+bool
+SetWindowPtr(unsigned long hwnd, long index, unsigned long p)
+ C_ARGS: hwnd, index, (PVOID)p
+
+bool
+SetWindowULong(unsigned long hwnd, long index, unsigned long i)
+
+bool
+SetWindowUShort(unsigned long hwnd, long index, unsigned short i)
+
+bool
+IsWindow(unsigned long hwnd, unsigned long hab = Acquire_hab())
+ C_ARGS: hab, hwnd
+
+BOOL
+ActiveWindow_set(unsigned long hwnd, unsigned long hwndDesktop = HWND_DESKTOP)
+ CODE:
+ RETVAL = SetActiveWindow(hwndDesktop, hwnd);
+
int
out_codepage()
bool
process_codepage_set(int cp)
+void
+cursor(OUTLIST int stp, OUTLIST int ep, OUTLIST int wp, OUTLIST int ap)
+ PROTOTYPE:
+
+bool
+cursor_set(int s, int e, int w = cursor__(0), int a = cursor__(1))
+
+MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myQuery
+
+SV *
+myQueryWindowText(unsigned long hwnd)
+
+SV *
+myQueryClassName(unsigned long hwnd)
+
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = Query
unsigned long
QueryWindowTextLength(unsigned long hwnd)
SV *
-QueryWindowText(unsigned long hwnd)
-
-SV *
QueryWindowSWP(unsigned long hwnd)
-SV *
-QueryClassName(unsigned long hwnd)
+unsigned long
+QueryWindowULong(unsigned long hwnd, long index)
-MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWin
+unsigned short
+QueryWindowUShort(unsigned long hwnd, long index)
+
+unsigned long
+QueryActiveWindow(unsigned long hwnd = HWND_DESKTOP)
+
+unsigned long
+QueryDesktopWindow(unsigned long hab = Acquire_hab(), unsigned long hdc = NULLHANDLE)
+
+MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery
+
+unsigned long
+myWinQueryWindowPtr(unsigned long hwnd, long index)
NO_OUTPUT BOOL
myWinQueryWindowProcess(unsigned long hwnd, OUTLIST unsigned long pid, OUTLIST unsigned long tid)
+ PROTOTYPE: $
POSTCALL:
if (CheckWinError(RETVAL))
- croak("QueryWindowProcess() error");
-
-void
-cursor(OUTLIST int stp, OUTLIST int ep, OUTLIST int wp, OUTLIST int ap)
+ croak("WindowProcess() error");
-bool
-cursor_set(int s, int e, int w = cursor__(0), int a = cursor__(1))
+MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWin
int
myWinSwitchToProgram(unsigned long hsw)
PREINIT:
ULONG rc;
-unsigned long
-myWinQueryActiveWindow(unsigned long hwnd = HWND_DESKTOP)
+MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = myWinQuery
MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = get
void
getscrsize(OUTLIST int wp, OUTLIST int hp)
+ PROTOTYPE:
bool
scrsize_set(int w_or_h, int h = -9999)
+
+MODULE = OS2::Process PACKAGE = OS2::Process PREFIX = ul
+
+unsigned long
+ulMPFROMSHORT(unsigned short i)
+
+unsigned long
+ulMPVOID()
+
+unsigned long
+ulMPFROMCHAR(unsigned char i)
+
+unsigned long
+ulMPFROM2SHORT(unsigned short x1, unsigned short x2)
+ PROTOTYPE: DISABLE
+
+unsigned long
+ulMPFROMSH2CH(unsigned short s, unsigned char c1, unsigned char c2)
+ PROTOTYPE: DISABLE
+
+unsigned long
+ulMPFROMLONG(unsigned long x)
+
--- /dev/null
+#! /usr/bin/perl -w
+
+#END {
+# sleep 10;
+#}
+
+sub propagate_INC {
+ my $inc = $ENV{PERL5LIB};
+ $inc = $ENV{PERLLIB} unless defined $inc;
+ $inc = '' unless defined $inc;
+ $ENV{PERL5LIB} = join ';', @INC, split /;/, $inc;
+}
+
+my $separate_session;
+BEGIN { # Remap I/O to the parent's window
+ $separate_session = $ENV{OS2_PROCESS_TEST_SEPARATE_SESSION};
+ propagate_INC, return unless $separate_session; # done by the parent
+ my @fn = split " ", $ENV{NEW_FD};
+ my @fh = (*STDOUT, *STDERR);
+ my @how = qw( > > );
+ # warn $_ for @fn;
+ open $fh[$_], "$how[$_]&=$fn[$_]"
+ or warn "Cannot reopen $fh[$_], $how[$_]&=$fn[$_]: $!" for 0..1;
+}
+
+use strict;
+use Test::More tests => 227;
+use OS2::Process;
+
+sub SWP_flags ($) {
+ my @nkpos = WindowPos shift;
+ $nkpos[2];
+}
+
+my $interactive_wait = @ARGV && $ARGV[0] eq 'wait';
+
+my @l = OS2::Process::process_entry();
+ok(@l == 11, 'all the fields of the process_entry() are there');
+
+# 1: FS 2: Window-VIO
+ok( ($l[9] == 1 or $l[9] == 2), 'we are FS or Windowed-VIO');
+
+#print "# $_\n" for @l;
+
+eval <<'EOE' or die;
+#use OS2::Process qw(WM_SYSCOMMAND WM_DBCSLAST FID_CLIENT HWND_DESKTOP);
+use OS2::Process qw(WM_SYSCOMMAND WM_DBCSLAST HWND_DESKTOP);
+
+ok( WM_SYSCOMMAND == 0x0021, 'correct WM_SYSCOMMAND' );
+ok( WM_DBCSLAST == 0x00cf, 'correct WM_DBCSLAST' );
+#ok( FID_CLIENT == 0x8008 );
+ok( HWND_DESKTOP == 0x0001, 'correct HWND_DESKTOP' );
+1;
+EOE
+
+my $t = Title;
+my $wint = winTitle;
+
+ok($t, 'got session title');
+ok($wint, 'got titlebar text');
+
+my $newt = "test OS2::Process $$";
+ok(Title_set($newt), 'successfully set Title');
+is(Title, $newt, 'correctly set Title');
+my $wt = winTitle or warn "winTitle: $!, $^E";
+is(winTitle, $newt, 'winTitle changed its value too');
+ok(Title_set $t, 'successfully set Title back');
+is(Title, $t, 'correctly set Title back');
+is(winTitle, $wint, 'winTitle restored its value too');
+
+$newt = "test OS2::Process both-$$";
+ok(bothTitle_set($newt), 'successfully set both titles via Win* API');
+is(Title, $newt, 'session title correctly set');
+is(winTitle, $newt, 'winTitle correctly set');
+ok(bothTitle_set($t), 'successfully reset both titles via Win* API');
+is(Title, $t, 'session title correctly reset');
+is(winTitle, $wint, 'winTitle correctly reset');
+
+$newt = "test OS2::Process win-$$";
+ok(winTitle_set($newt), 'successfully set titlebar title via Win* API');
+is(Title, $t, 'session title remained the same');
+is(winTitle, $newt, 'winTitle changed value');
+ok(winTitle_set($wint), 'successfully reset titlebar title via Win* API');
+is(Title, $t, 'session title remained the same');
+is(winTitle, $wint, 'winTitle restored value');
+
+$newt = "test OS2::Process sw-$$";
+ok(swTitle_set($newt), 'successfully set session title via Win* API');
+is(Title, $newt, 'session title correctly set');
+is(winTitle, $wint, 'winTitle has unchanged value');
+ok(swTitle_set($t), 'successfully reset session title via Win* API');
+is(Title, $t, 'session title correctly set');
+is(winTitle, $wint, 'winTitle has unchanged value');
+
+$newt = "test OS2::Process again-$$";
+ok(Title_set($newt), 'successfully set Title again');
+is(Title, $newt, 'correctly set Title again');
+is(winTitle, $newt, 'winTitle changed its value too again');
+ok(Title_set($t), 'successfully set Title back');
+is(Title, $t, 'correctly set Title back');
+is(winTitle, $wint, 'winTitle restored its value too again');
+
+my $hwnd = process_hwnd;
+ok($hwnd, 'found session owner hwnd');
+my $c_subhwnd = WindowFromId $hwnd, 0x8008; # FID_CLIENT;
+ok($c_subhwnd, 'found client hwnd');
+my $a_subhwnd = ActiveWindow $hwnd; # or $^E and warn $^E;
+ok((not $a_subhwnd and not $^E), 'No active subwindow in a VIO frame');
+
+my $ahwnd = ActiveWindow;
+ok($ahwnd, 'found active window');
+my $fhwnd = FocusWindow;
+ok($fhwnd, 'found focus window');
+
+# This call without morphing results in VIO window with active highlight, but
+# no keyboard focus (even after Alt-Tabbing to it; you cannot Alt-Tab off it!)
+
+# Interestingly, Desktop is active on the switch list, but the
+# switch list is not acting on keyboard events.
+
+# Give up focus
+{ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally';
+ ok FocusWindow_set(1), 'set focus to DESKTOP'; # HWND_DESKTOP
+}
+my $dtop = DesktopWindow;
+ok($dtop, 'found the desktop window');
+
+#OS2::Process::ResetWinError; # XXXX Should not be needed!
+$ahwnd = ActiveWindow or $^E and warn $^E;
+ok( (not $ahwnd and not $^E), 'desktop is not active');
+$fhwnd = FocusWindow;
+ok($fhwnd, 'there is a focus window');
+is($fhwnd, $dtop, 'which is the desktop');
+
+# XXXX Well, no need to skip it now...
+SKIP: {
+ skip 'We already have focus', 4 if $hwnd == $ahwnd;
+ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally again';
+ ok FocusWindow_set($c_subhwnd), 'set focus to the client of the session owner';
+ # If we do not morph, then when the focus is in another VIO frame,
+ # we get two VIO frames with activated titlebars.
+ # The only (?) way to take the activated state from another frame
+ # is to switch to it via the switch list
+ $ahwnd = ActiveWindow;
+ ok($ahwnd, 'there is an active window');
+ $fhwnd = FocusWindow;
+ ok($fhwnd, 'there is a focus window');
+ is($hwnd, $ahwnd, 'the active window is the session owner');
+ is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner');
+}
+
+# Give up focus again
+{ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally again';
+ ok FocusWindow_set(1), 'set focus to DESKTOP again'; # HWND_DESKTOP
+}
+
+$ahwnd = ActiveWindow or $^E and warn $^E;
+ok( (not $ahwnd and not $^E), 'desktop is not active again');
+$fhwnd = FocusWindow;
+ok($fhwnd, 'there is a focus window');
+is($fhwnd, $dtop, 'which is the desktop');
+
+# XXXX Well, no need to skip it now...
+SKIP: {
+ skip 'We already have focus', 4 if $hwnd == $ahwnd;
+ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally again';
+ ok ActiveWindow_set($hwnd), 'activate the session owner';
+ $ahwnd = ActiveWindow;
+ ok($ahwnd, 'there is an active window');
+ $fhwnd = FocusWindow;
+ ok($fhwnd, 'there is a focus window');
+ is($hwnd, $ahwnd, 'the active window is the session owner');
+}
+
+# XXXX Well, no need to skip it now...
+SKIP: {
+ skip 'Tests assume we have focus', 1 unless $hwnd == $ahwnd;
+ # We have focus
+ # is($fhwnd, $ahwnd);
+ # is($a_subhwnd, $c_subhwnd);
+ is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner');
+}
+
+# Check enumeration of switch entries:
+my $skid_title = "temporary s-kid ppid=$$";
+my $spid = system P_SESSION, $^X, '-wle', "END {sleep 25} use OS2::Process; eval {Title_set '$skid_title'} or warn \$@; \$SIG{TERM} = sub {exit 0}";
+ok ($spid, 'start the new VIO session with unique title');
+sleep 1;
+my @sw = grep $_->{title} eq $skid_title, process_hentries;
+sleep 1000 unless @sw;
+is(scalar @sw, 1, 'exactly one session with this title');
+my $sw = $sw[0];
+ok $sw, 'have the data about the session';
+is($sw->{owner_pid}, $spid, 'session has a correct pid');
+my $k_hwnd = $sw->{owner_hwnd};
+ok $k_hwnd, 'found the session window handle';
+is sidOf($spid), $sw->{owner_sid}, 'we know sid of the session';
+
+# Give up focus again
+{ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally again';
+ ok FocusWindow_set($k_hwnd), 'set focus to kid session window';
+}
+
+$ahwnd = ActiveWindow;
+ok $ahwnd, 'there is an active window';
+is $ahwnd, $k_hwnd, 'after focusing the active window is the owner_hwnd';
+$fhwnd = FocusWindow;
+ok $fhwnd, 'there is a focus window';
+my $c_sub_ahwnd = WindowFromId $ahwnd, 0x8008; # FID_CLIENT;
+ok $c_sub_ahwnd, 'the active window has a FID_CLIENT';
+is($fhwnd, $ahwnd, 'the focus window = the active window');
+
+ok hWindowPos_set({behind => 3}, $k_hwnd), # HWND_TOP
+ 'put kid to the front';
+
+is((hWindowPos $k_hwnd)->{behind}, 3, 'kis is at front');
+
+my ($enum_handle, $first_zorder);
+{ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally again';
+ $enum_handle = BeginEnumWindows 1; # HWND_DESKTOP
+ ok $enum_handle, 'start enumeration';
+ $first_zorder = GetNextWindow $enum_handle;
+ ok $first_zorder, 'GetNextWindow works';
+ ok EndEnumWindows($enum_handle), 'end enumeration';
+}
+is ($first_zorder, $k_hwnd, 'kid is the first in z-order enumeration');
+
+ok hWindowPos_set({behind => 4}, $k_hwnd), # HWND_BOTTOM
+ 'put kid to the back';
+
+# This does not work, the result is the handle of "Window List"
+# is((hWindowPos $k_hwnd)->{behind}, 4, 'kis is at back');
+
+my (@list, $next);
+{ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally again';
+ $enum_handle = BeginEnumWindows 1; # HWND_DESKTOP
+ ok $enum_handle, 'start enumeration';
+ push @list, $next while $next = GetNextWindow $enum_handle;
+ ok EndEnumWindows($enum_handle), 'end enumeration';
+
+ # Apparently, the 'Desktop' window is still behind us;
+ # Note that this window is *not* what is returned by DesktopWindow
+ pop @list if WindowText($list[-1]) eq 'Desktop';
+}
+is ($list[-1], $k_hwnd, 'kid is the last in z-order enumeration');
+# print "# kid=$k_hwnd in @list\n";
+@list = ChildWindows; # HWND_DESKTOP
+ok scalar @list, 'ChildWindows works';
+is $list[-2], $k_hwnd, 'kid is the last but one in ChildWindows';
+
+ok hWindowPos_set({behind => 3}, $k_hwnd), # HWND_TOP
+ 'put kid to the front again';
+
+is((hWindowPos $k_hwnd)->{behind}, 3, 'kis is at front again');
+sleep 5 if $interactive_wait;
+
+ok IsWindow($k_hwnd), 'IsWindow works';
+#print "# win=$k_hwnd => err=$^E\n";
+my $c_sub_khwnd = WindowFromId $k_hwnd, 0x8008; # FID_CLIENT
+ok $c_sub_khwnd, 'have kids client window';
+ok IsWindow($c_sub_khwnd), 'IsWindow works on the client';
+#print "# win=$c_sub_khwnd => IsWindow err=$^E\n";
+my ($pkid,$tkid) = WindowProcess $c_sub_khwnd;
+my ($pkid1,$tkid1) = WindowProcess $hwnd;
+ok($pkid1 > 0, 'our window has a governing process');
+ok($tkid1 > 0, 'our window has a governing thread');
+is($pkid, $pkid1, 'kid\'s window is governed by the same process as our (PMSHELL:1)');
+is($tkid, $tkid1, 'likewise for threads');
+is $pkid, ppidOf($spid), 'the governer is the parent of the kid session';
+
+my $my_pos = hWindowPos($hwnd);
+ok $my_pos, 'got my position';
+{ my $force_PM = OS2::localMorphPM->new(0);
+ ok $force_PM, 'morphed to PM locally again';
+ my @pos = WindowPos $hwnd;
+ my @ppos = WindowPos $k_hwnd;
+ # ok hWindowPos_set({%$my_pos, behind => $hwnd}, $k_hwnd), 'hide the kid behind us';
+ # Hide it completely behind our window
+ ok hWindowPos_set({x => $my_pos->{x}, y => $my_pos->{y}, behind => $hwnd,
+ width => $my_pos->{width}, height => $my_pos->{height}},
+ $k_hwnd), 'hide the kid behind us';
+ # ok WindowPos_set($k_hwnd, $pos[0], $pos[1]), 'hide the kid behind us';
+ my @kpos = WindowPos $k_hwnd;
+ # print "# kidpos=@ppos\n";
+ # print "# mypos=@pos\n";
+ # print "# kidpos=@kpos\n";
+# kidpos=252 630 4111 808 478 3 66518088 502482793
+# mypos=276 78 4111 491 149 2147484137 66518060 502532977
+# kidpos=276 78 4111 491 149 2147484255 1392374582 213000
+ print "# Before window position\n" if $interactive_wait;
+ sleep 5 if $interactive_wait;
+
+ my $w_at = WindowFromPoint($kpos[0] + 5, $kpos[0] + 5, 1, 0); # HWND_DESKTOP, no grandchildren
+ ok $w_at, 'got window near LL corner of the kid';
+ print "# we=$hwnd, our client=$c_subhwnd, kid=$k_hwnd, kid's client=$c_sub_khwnd\n";
+ #is $w_at, $c_sub_khwnd, 'it is the kids client';
+ #is $w_at, $k_hwnd, 'it is the kids frame';
+ # Apparently, this result is accidental only...
+# is $w_at, $hwnd, 'it is our frame - is on top, but no focus';
+ #is $w_at, $c_subhwnd, 'it is our client';
+ print "# text: `", WindowText $w_at, "'.\n";
+ $w_at = WindowFromPoint($kpos[0] + 5, $kpos[0] + 5); # HWND_DESKTOP, grandchildren too
+ ok $w_at, 'got grandkid window near LL corner of the kid';
+ # Apparently, this result is accidental only...
+# is $w_at, $c_subhwnd, 'it is our client';
+ print "# text: `", WindowText $w_at, "'.\n";
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ ok IsWindowShowing $hwnd, 'we are showing';
+ ok ((not IsWindowShowing $k_hwnd), 'kid is not showing');
+ ok ((not eval { IsWindowShowing 12; 1 }), 'wrong kid causes errors');
+ is $^E+0, 0x1001, 'error is 0x1001';
+ like $@, qr/\Q[Win]IsWindowShowing/, 'error message shows function';
+ like $@, qr/SYS4097\b/, 'error message shows error number';
+ like $@, qr/\b0x1001\b/, 'error message shows error number in hex';
+
+ ok WindowPos_set($k_hwnd, @ppos[0..5]), 'restore the kid position';
+ my @nkpos = WindowPos $k_hwnd;
+ my $fl = $nkpos[2];
+ is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored');
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ sleep 5 if $interactive_wait;
+ ok EnableWindow($k_hwnd, 0), 'disable the kid';
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok !IsWindowEnabled $k_hwnd, 'kid is flaged as not enabled';
+ ok EnableWindow($k_hwnd), 'enable the kid';
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ ok ShowWindow($k_hwnd, 0), 'hide the kid';
+ ok !IsWindowShowing $k_hwnd, 'kid is not showing';
+ ok !IsWindowVisible $k_hwnd, 'kid is flaged as not visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ ok ShowWindow($k_hwnd), 'show the kid';
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ ok( ($fl & 0x1800), 'window is maximized or restored'); # SWP_MAXIMIZE SWP_RESTORE
+ ok( ($fl & 0x1800) != 0x1800, 'window is not maximized AND restored'); # SWP_MAXIMIZE SWP_RESTORE
+
+ ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE
+ OS2::Process::MPFROMSHORT 0x8002), 'post minimize message';
+ sleep 1;
+ ok !IsWindowShowing $k_hwnd, 'kid is not showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE
+
+ ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE
+ OS2::Process::MPFROMSHORT 0x8008), 'post restore message';
+ sleep 1;
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE
+
+ ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MAXIMIZE
+ OS2::Process::MPFROMSHORT 0x8003), 'post maximize message';
+ sleep 1;
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x800, 'kid is maximized'; # SWP_MAXIMIZE
+
+ ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE
+ OS2::Process::MPFROMSHORT 0x8002), 'post minimize message again';
+ sleep 1;
+ ok !IsWindowShowing $k_hwnd, 'kid is not showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE
+
+ ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE
+ OS2::Process::MPFROMSHORT 0x8008), 'post restore message again';
+ sleep 1;
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE
+
+ ok PostMsg( $k_hwnd, 0x21, # WM_SYSCOMMAND, SC_MINIMIZE
+ OS2::Process::MPFROMSHORT 0x8002), 'post minimize message again';
+ sleep 1;
+ ok !IsWindowShowing $k_hwnd, 'kid is not showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE
+
+ ok PostMsg($k_hwnd, 0x21, # WM_SYSCOMMAND, SC_RESTORE
+ OS2::Process::MPFROMSHORT (($fl & 0x800) ? 0x8003 : 0x8008)), # SWP_MAXIMIZE
+ 'return back to the initial MAXIMIZE/RESTORE state';
+ sleep 1;
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ @nkpos = WindowPos $k_hwnd;
+ is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored');
+
+ # Now the other way
+ ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized';
+ ok !IsWindowShowing $k_hwnd, 'kid is not showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE
+
+ ok hWindowPos_set( {flags => 0x1000}, $k_hwnd), 'set to restore';
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE
+
+ ok hWindowPos_set( {flags => 0x800}, $k_hwnd), 'set to maximized';
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x800, 'kid is maximized'; # SWP_MAXIMIZE
+
+ ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized again';
+ ok !IsWindowShowing $k_hwnd, 'kid is not showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE
+
+ ok hWindowPos_set( {flags => 0x1000}, $k_hwnd), 'set to restore again';
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x1000, 'kid is restored'; # SWP_RESTORE
+
+ ok hWindowPos_set( {flags => 0x400}, $k_hwnd), 'set to minimized again';
+ ok !IsWindowShowing $k_hwnd, 'kid is not showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ is 0x1c00 & SWP_flags $k_hwnd, 0x400, 'kid is minimized'; # SWP_MINIMIZE
+
+ ok hWindowPos_set( {flags => ($fl & 0x1800)}, $k_hwnd),
+ 'set back to the initial MAXIMIZE/RESTORE state';
+ ok IsWindowShowing $k_hwnd, 'kid is showing';
+ ok IsWindowVisible $k_hwnd, 'kid is flaged as visible';
+ ok IsWindowEnabled $k_hwnd, 'kid is flaged as enabled';
+ @nkpos = WindowPos $k_hwnd;
+ is_deeply([@ppos[0..5]], [@nkpos[0..5]], 'position restored');
+
+}
+
+# XXXX Well, no need to skip it now...
+SKIP: {
+ skip 'We already have focus', 4 if $hwnd == $ahwnd;
+ my $force_PM = OS2::localMorphPM->new(0);
+ ok($force_PM, 'morphed to catch focus again');
+ ok FocusWindow_set($c_subhwnd), 'set focus to the client of the session owner';
+ # If we do not morph, then when the focus is in another VIO frame,
+ # we get two VIO frames with activated titlebars.
+ # The only (?) way to take the activated state from another frame
+ # is to switch to it via the switch list
+ $ahwnd = ActiveWindow;
+ ok($ahwnd, 'there is an active window');
+ $fhwnd = FocusWindow;
+ ok($fhwnd, 'there is a focus window');
+ is($hwnd, $ahwnd, 'the active window is the session owner');
+ is($fhwnd, $c_subhwnd, 'the focus window is the client of the session owner');
+}
+
+SKIP: {
+ skip 'Potentially destructive session modifications, done in a separate session only',
+ 12, unless $separate_session;
+ # Manipulate process' hentry
+ my $he = process_hentry;
+ ok($he, 'got process hentry');
+ ok($he->{visible}, 'session switch is visible');# 4? Assume nobody manipulated it...
+
+ ok change_entryh($he), 'can change it (without modifications)';
+ my $nhe = process_hentry;
+ ok $nhe, 'could refetch the process hentry';
+ is_deeply($nhe, $he, 'it did not change');
+
+ sleep 5 if $interactive_wait;
+ # Try removing the process entry from the switch list
+ $nhe->{visible} = 0;
+ ok change_entryh($nhe), 'can change it to be invisible';
+ my $nnhe = process_hentry;
+ ok($nnhe, 'could refetch the process hentry');
+ is_deeply($nnhe, $nhe, 'it is modified as expected');
+ is($nnhe->{visible}, 0, 'it is not visible');
+
+ sleep 5 if $interactive_wait;
+
+ $nhe->{visible} = 1;
+ ok change_entryh ($nhe), 'can change it to be visible';
+ $nnhe = process_hentry;
+ ok($nnhe, 'could refetch the process hentry');
+ ok($nnhe->{visible}, 'it is visible');
+ sleep 5 if $interactive_wait;
+}
--- /dev/null
+#! /usr/bin/perl -w
+
+use strict;
+use OS2::Process; # qw(P_SESSION P_UNRELATED P_NOWAIT);
+
+my $pl = $0;
+$pl =~ s/_kid\.t$/.t/i;
+die "Can't find the kid script" unless -r $pl;
+
+my $inc = $ENV{PERL5LIB};
+$inc = $ENV{PERLLIB} unless defined $inc;
+$inc = '' unless defined $inc;
+$ENV{PERL5LIB} = join ';', @INC, split /;/, $inc;
+
+# The thest in $pl modify the session too bad. We run the tests
+# in a different session to keep the current session cleaner
+
+# Apparently, this affects things at open() time, not at system() time
+$^F = 40;
+
+# These do not work... Apparently, the kid "interprets" file handles
+# open to CON as output to *its* CON (shortcut in the kernel via the
+# device flags?).
+
+#my @fh = ('<&STDIN', '>&STDOUT', '>&STDERR');
+#my @nfd;
+#open $nfd[$_], $fh[$_] or die "Cannot remap FH" for 0..2;
+#my @fn = map fileno $_, @nfd;
+#$ENV{NEW_FD} = "@fn";
+
+my ($stdout_r,$stdout_w,$stderr_r,$stderr_w);
+pipe $stderr_r, $stderr_w or die;
+
+# Duper for $stderr_r to STDERR
+my ($e_r, $e_w) = map fileno $_, $stderr_r, $stderr_w;
+my $k = system P_NOWAIT, $^X, '-we', <<'EOS', $e_r, $e_w or die "Cannot start a STDERR duper";
+ my ($e_r, $e_w) = @ARGV;
+ # close the other end by the implicit close:
+ { open my $closeit, ">&=$e_w" or die "kid: open >&=$e_w: $!, `$^E'" }
+ open IN, "<&=$e_r" or die "kid: open <&=$e_r: $!, `$^E'";
+ select STDERR; $| = 1; print while sysread IN, $_, 1<<16;
+EOS
+close $stderr_r or die; # Now the kid is the owner
+
+pipe $stdout_r, $stdout_w or die;
+
+my @fn = (map fileno $_, $stdout_w, $stderr_w);
+$ENV{NEW_FD} = "@fn";
+# print "# fns=@fn\n";
+
+$ENV{OS2_PROCESS_TEST_SEPARATE_SESSION} = 1;
+my $pid = system P_SESSION, $^X, $pl, @ARGV or die;
+close $stderr_w or die; # Leave these two FH to the kid only
+close $stdout_w or die;
+
+# Duplicate the STDOUT of the kid:
+# These are workarounds for bug in sysread: it is reading in binary...
+binmode $stdout_r;
+binmode STDOUT;
+$| = 1; print while sysread $stdout_r, $_, 1<<16;
+
+waitpid($pid, 0) >= 0 or die;
+
+# END { print "# parent finished\r\n" }
--- /dev/null
+#! /usr/bin/perl -w
+
+BEGIN {
+ my $inc = $ENV{PERL5LIB};
+ $inc = $ENV{PERLLIB} unless defined $inc;
+ $inc = '' unless defined $inc;
+ $ENV{PERL5LIB} = join ';', @INC, split /;/, $inc;
+}
+
+use strict;
+use Test::More tests => 11;
+use OS2::Process;
+
+my $cmd = <<'EOA';
+use OS2::Process;
+$| = 1;
+print for $$, ppid, sidOf;
+$SIG{TERM} = $SIG{INT} = sub {exit};
+sleep 10;
+EOA
+
+#my $PID = open my $fh, '-|', $^X, '-wle', $cmd;
+$ENV{CMD_RUN} = $cmd;
+my $PID = open my $fh, '-|', "$^X -wle 'eval \$ENV{CMD_RUN} or die'";
+ok $PID, 'opened a pipe';
+my ($kpid, $kppid, $sid);
+$kpid = <$fh>;
+$kppid = <$fh>;
+$sid = <$fh>;
+chomp ($kpid, $kppid, $sid);
+
+# This does not work with the intervening shell...
+my $extra_fork = $kppid == $PID; # Temporary implementation of multi-arg open()
+
+print "# us=$$, immediate-pid=$PID, parent-of-kid=$kppid, kid=$kpid\n";
+if ($ENV{CMD_RUN}) { # Two copies of the shell intervene...
+ is( ppidOf($kppid), $PID, 'correct pid of the kid or its parent');
+ is( ppidOf($PID), $$, 'we know our child\'s parent');
+} else {
+ is( ($extra_fork ? $kppid : $kpid), $PID, 'correct pid of the kid');
+ is( $kppid, ($extra_fork ? $PID : $$), 'kid knows its ppid');
+}
+ok $sid >= 0, 'kid got its sid';
+is($sid, sidOf, 'sid of kid same as our');
+is(sidOf($kpid), $sid, 'we know sid of kid');
+is(sidOf($PID), $sid, 'we know sid of inter-kid');
+is(ppidOf($kpid), $kppid, 'we know ppid of kid');
+is(ppidOf($PID), $$, 'we know ppid of inter-kid');
+
+ok kill('TERM', $kpid), 'killed the kid';
+#ok( ($PID == $kpid or kill('TERM', $PID)), 'killed the inter-kid');
+ok close $fh, 'closed the pipe'; # No kid any more
{&pmwin_handle, NULL, 875}, /* WinSetWindowPos */
{&pmwin_handle, NULL, 877}, /* WinSetWindowText */
{&pmwin_handle, NULL, 883}, /* WinShowWindow */
- {&pmwin_handle, NULL, 872}, /* WinIsWindow */
+ {&pmwin_handle, NULL, 772}, /* WinIsWindow */
{&pmwin_handle, NULL, 899}, /* WinWindowFromId */
{&pmwin_handle, NULL, 900}, /* WinWindowFromPoint */
{&pmwin_handle, NULL, 919}, /* WinPostMsg */
+ {&pmwin_handle, NULL, 735}, /* WinEnableWindow */
+ {&pmwin_handle, NULL, 736}, /* WinEnableWindowUpdate */
+ {&pmwin_handle, NULL, 773}, /* WinIsWindowEnabled */
+ {&pmwin_handle, NULL, 774}, /* WinIsWindowShowing */
+ {&pmwin_handle, NULL, 775}, /* WinIsWindowVisible */
+ {&pmwin_handle, NULL, 839}, /* WinQueryWindowPtr */
+ {&pmwin_handle, NULL, 843}, /* WinQueryWindowULong */
+ {&pmwin_handle, NULL, 844}, /* WinQueryWindowUShort */
+ {&pmwin_handle, NULL, 874}, /* WinSetWindowBits */
+ {&pmwin_handle, NULL, 876}, /* WinSetWindowPtr */
+ {&pmwin_handle, NULL, 878}, /* WinSetWindowULong */
+ {&pmwin_handle, NULL, 879}, /* WinSetWindowUShort */
+ {&pmwin_handle, NULL, 813}, /* WinQueryDesktopWindow */
+ {&pmwin_handle, NULL, 851}, /* WinSetActiveWindow */
+ {&doscalls_handle, NULL, 360}, /* DosQueryModFromEIP */
};
static PFN ExtFCN[C_ARR_LEN(loadOrdinals)]; /* Labeled by ord ORD_*. */
if (pDosVerifyPidTid) { /* Warp3 or later */
/* Up to some fixpak QuerySysState() kills the system if a non-existent
pid is used. */
- if (!pDosVerifyPidTid(pid, 1))
+ if (CheckOSError(pDosVerifyPidTid(pid, 1)))
return 0;
}
New(1322, pbuffer, buf_len, char);
return buf;
}
+void
+ResetWinError(void)
+{
+ WinError_2_Perl_rc;
+}
+
+void
+CroakWinError(int die, char *name)
+{
+ FillWinError;
+ if (die && Perl_rc)
+ croak("%s: %s", (name ? name : "Win* API call"), os2error(Perl_rc));
+}
+
char *
os2_execname(pTHX)
{
PPIB pib;
PTIB tib;
- if (Perl_os2_initial_mode++)
+ if (Perl_hmq_refcnt > 0)
return Perl_hmq;
+ Perl_hmq_refcnt = 0; /* Be extra safe */
DosGetInfoBlocks(&tib, &pib);
Perl_os2_initial_mode = pib->pib_ultype;
/* Try morphing into a PM application. */
XSRETURN(1);
}
+/* Input: Address, BufLen
+APIRET APIENTRY
+DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
+ ULONG * Offset, ULONG Address);
+*/
+
+DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP,
+ (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf,
+ ULONG * Offset, ULONG Address),
+ (hmod, obj, BufLen, Buf, Offset, Address))
+
+enum module_name_how { mod_name_handle, mod_name_shortname, mod_name_full};
+
+static SV*
+module_name_at(void *pp, enum module_name_how how)
+{
+ char buf[MAXPATHLEN];
+ char *p = buf;
+ HMODULE mod;
+ ULONG obj, offset, rc;
+
+ if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)pp))
+ return &PL_sv_undef;
+ if (how == mod_name_handle)
+ return newSVuv(mod);
+ /* Full name... */
+ if ( how == mod_name_full
+ && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) )
+ return &PL_sv_undef;
+ while (*p) {
+ if (*p == '\\')
+ *p = '/';
+ p++;
+ }
+ return newSVpv(buf, 0);
+}
+
+static SV*
+module_name_of_cv(SV *cv, enum module_name_how how)
+{
+ if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv)))
+ croak("Not an XSUB reference");
+ return module_name_at(CvXSUB(SvRV(cv)), how);
+}
+
+/* Find module name to which *this* subroutine is compiled */
+#define module_name(how) module_name_at(&module_name_at, how)
+
+XS(XS_OS2_DLLname)
+{
+ dXSARGS;
+ if (items > 2)
+ Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )");
+ {
+ SV * RETVAL;
+ int how;
+
+ if (items < 1)
+ how = mod_name_full;
+ else {
+ how = (int)SvIV(ST(0));
+ }
+ if (items < 2)
+ RETVAL = module_name(how);
+ else
+ RETVAL = module_name_of_cv(ST(1), how);
+ ST(0) = RETVAL;
+ sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
#define get_control87() _control87(0,0)
#define set_control87 _control87
newXSproto("OS2::_control87", XS_OS2__control87, file, "$$");
newXSproto("OS2::get_control87", XS_OS2_get_control87, file, "");
newXSproto("OS2::set_control87", XS_OS2_set_control87, file, ";$$");
+ newXSproto("OS2::DLLname", XS_OS2_DLLname, file, ";$$");
gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
GvMULTI_on(gv);
#ifdef PERL_IS_AOUT
+#!/usr/bin/perl -w
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Test::More tests => 24;
+use strict;
+use Config;
+
+my $cwd = Cwd::sys_cwd();
+ok 1;
+ok -d $cwd;
+
+my $lpb = Cwd::extLibpath;
+ok 1;
+$lpb .= ';' unless $lpb and $lpb =~ /;$/;
+
+my $lpe = Cwd::extLibpath(1);
+ok 1;
+$lpe .= ';' unless $lpe and $lpe =~ /;$/;
+
+ok Cwd::extLibpath_set("$lpb$cwd");
+
+$lpb = Cwd::extLibpath;
+ok 1;
+$lpb =~ s#\\#/#g;
+(my $s_cwd = $cwd) =~ s#\\#/#g;
+
+like($lpb, qr/\Q$s_cwd/);
+
+ok Cwd::extLibpath_set("$lpe$cwd", 1);
+
+$lpe = Cwd::extLibpath(1);
+ok 1;
+$lpe =~ s#\\#/#g;
+
+like($lpe, qr/\Q$s_cwd/);
+
+is(uc OS2::DLLname(1), uc $Config{dll_name});
+like(OS2::DLLname, qr#\Q/$Config{dll_name}\E\.dll$#i );
+(my $root_cwd = $s_cwd) =~ s,/t$,,;
+like(OS2::DLLname, qr#^\Q$root_cwd\E(/t)?\Q/$Config{dll_name}\E\.dll#i );
+is(OS2::DLLname, OS2::DLLname(2));
+like(OS2::DLLname(0), qr#^(\d+)$# );
+
+
+is(OS2::DLLname($_), OS2::DLLname($_, \&Cwd::extLibpath) ) for 0..2;
+ok(not defined eval { OS2::DLLname $_, \&Cwd::cwd; 1 } ) for 0..2;
+ok(not defined eval { OS2::DLLname $_, \&xxx; 1 } ) for 0..2;
print "1.." . lasttest() . "\n";
$cwd = Cwd::sys_cwd();
unshift @INC, 'lib';
require OS2::Process;
-@l = OS2::Process::process_entry();
+my @l = OS2::Process::process_entry();
print "not " unless @l == 11;
print "ok 11\n";
/* INCL_DOSERRORS needed. rc should be declared outside. */
#define CheckOSError(expr) (!(rc = (expr)) ? 0 : (FillOSError(rc), 1))
/* INCL_WINERRORS needed. */
-#define SaveWinError(expr) ((expr) ? : (FillWinError, 0))
#define CheckWinError(expr) ((expr) ? 0: (FillWinError, 1))
+
+/* This form propagates the return value, setting $^E if needed */
+#define SaveWinError(expr) ((expr) ? : (FillWinError, 0))
+
+/* This form propagates the return value, dieing with $^E if needed */
+#define SaveCroakWinError(expr,die,name1,name2) \
+ ((expr) ? : (CroakWinError(die,name1 name2), 0))
+
#define FillOSError(rc) (os2_setsyserrno(rc), \
Perl_severity = SEVERITY_ERROR)
+#define WinError_2_Perl_rc \
+ ( init_PMWIN_entries(), \
+ Perl_rc=(*PMWIN_entries.GetLastError)(perl_hab_GET()) )
+
+/* Calling WinGetLastError() resets the error code of the current thread.
+ Since for some Win* API return value 0 is normal, one needs to call
+ this before calling them to distinguish normal and anomalous returns. */
+/*#define ResetWinError() WinError_2_Perl_rc */
+
/* At this moment init_PMWIN_entries() should be a nop (WinInitialize should
be called already, right?), so we do not risk stepping over our own error */
-#define FillWinError ( init_PMWIN_entries(), \
- Perl_rc=(*PMWIN_entries.GetLastError)(perl_hab_GET()),\
+#define FillWinError ( WinError_2_Perl_rc, \
Perl_severity = ERRORIDSEV(Perl_rc), \
Perl_rc = ERRORIDERROR(Perl_rc), \
os2_setsyserrno(Perl_rc))
ORD_WinWindowFromId,
ORD_WinWindowFromPoint,
ORD_WinPostMsg,
+ ORD_WinEnableWindow,
+ ORD_WinEnableWindowUpdate,
+ ORD_WinIsWindowEnabled,
+ ORD_WinIsWindowShowing,
+ ORD_WinIsWindowVisible,
+ ORD_WinQueryWindowPtr,
+ ORD_WinQueryWindowULong,
+ ORD_WinQueryWindowUShort,
+ ORD_WinSetWindowBits,
+ ORD_WinSetWindowPtr,
+ ORD_WinSetWindowULong,
+ ORD_WinSetWindowUShort,
+ ORD_WinQueryDesktopWindow,
+ ORD_WinSetActiveWindow,
+ ORD_DosQueryModFromEIP,
ORD_NENTRIES
};
#define AssignFuncPByORD(p,o) (*(Perl_PFN*)&(p) = (loadByOrdinal(o, 1)))
+/* This flavor caches the procedure pointer (named as p__Win#name) locally */
+#define DeclWinFuncByORD_CACHE(ret,name,o,at,args) \
+ DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,1)
+
+/* This flavor may reset the last error before the call (if ret=0 may be OK) */
+#define DeclWinFuncByORD_CACHE_resetError(ret,name,o,at,args) \
+ DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,1)
+
+/* Two flavors below do the same as above, but do not auto-croak */
+/* This flavor caches the procedure pointer (named as p__Win#name) locally */
+#define DeclWinFuncByORD_CACHE_survive(ret,name,o,at,args) \
+ DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,0)
+
+/* This flavor may reset the last error before the call (if ret=0 may be OK) */
+#define DeclWinFuncByORD_CACHE_resetError_survive(ret,name,o,at,args) \
+ DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,0)
+
+#define DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,r,die) \
+ static ret (*CAT2(p__Win,name)) at; \
+ static ret name at { \
+ if (!CAT2(p__Win,name)) \
+ AssignFuncPByORD(CAT2(p__Win,name), o); \
+ if (r) ResetWinError(); \
+ return SaveCroakWinError(CAT2(p__Win,name) args, die, "[Win]", STRINGIFY(name)); }
+
+/* These flavors additionally assume ORD is name with prepended ORD_Win */
+#define DeclWinFunc_CACHE(ret,name,at,args) \
+ DeclWinFuncByORD_CACHE(ret,name,CAT2(ORD_Win,name),at,args)
+#define DeclWinFunc_CACHE_resetError(ret,name,at,args) \
+ DeclWinFuncByORD_CACHE_resetError(ret,name,CAT2(ORD_Win,name),at,args)
+#define DeclWinFunc_CACHE_survive(ret,name,at,args) \
+ DeclWinFuncByORD_CACHE_survive(ret,name,CAT2(ORD_Win,name),at,args)
+#define DeclWinFunc_CACHE_resetError_survive(ret,name,at,args) \
+ DeclWinFuncByORD_CACHE_resetError_survive(ret,name,CAT2(ORD_Win,name),at,args)
+
+void ResetWinError(void);
+void CroakWinError(int die, char *name);
+
#define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n))
char *perllib_mangle(char *, unsigned int);
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
- ,"DEVEL14680"
+ ,"DEVEL14709"
,NULL
};
=head1 NAME
-perlfaq3 - Programming Tools ($Revision: 1.13 $, $Date: 2002/02/08 22:32:47 $)
+perlfaq3 - Programming Tools ($Revision: 1.15 $, $Date: 2002/02/11 19:29:52 $)
=head1 DESCRIPTION
print "Hello world\n"
(then Run "Myscript" or Shift-Command-R)
+ # MPW
+ perl -e 'print "Hello world\n"'
+
# VMS
perl -e "print ""Hello world\n"""
Using qq(), q(), and qx(), instead of "double quotes", 'single
quotes', and `backticks`, may make one-liners easier to write.
-There is no general solution to all of this. It is a mess, pure and
-simple. Sucks to be away from Unix, huh? :-)
+There is no general solution to all of this. It is a mess.
[Some of this answer was contributed by Kenneth Albanowski.]
=head1 NAME
-perlfaq5 - Files and Formats ($Revision: 1.8 $, $Date: 2002/01/28 04:17:26 $)
+perlfaq5 - Files and Formats ($Revision: 1.9 $, $Date: 2002/02/11 19:30:21 $)
=head1 DESCRIPTION
=head2 How can I reliably rename a file?
-Well, usually you just use Perl's rename() function. That may not
-work everywhere, though, particularly when renaming files across file systems.
-Some sub-Unix systems have broken ports that corrupt the semantics of
-rename()--for example, WinNT does this right, but Win95 and Win98
-are broken. (The last two parts are not surprising, but the first is. :-)
-
-If your operating system supports a proper mv(1) program or its moral
+If your operating system supports a proper mv(1) utility or its functional
equivalent, this works:
rename($old, $new) or system("mv", $old, $new);
-It may be more compelling to use the File::Copy module instead. You
-just copy to the new file to the new name (checking return values),
-then delete the old one. This isn't really the same semantically as a
-real rename(), though, which preserves metainformation like
+It may be more portable to use the File::Copy module instead.
+You just copy to the new file to the new name (checking return
+values), then delete the old one. This isn't really the same
+semantically as a rename(), which preserves meta-information like
permissions, timestamps, inode info, etc.
-Newer versions of File::Copy exports a move() function.
+Newer versions of File::Copy export a move() function.
=head2 How can I lock a file?
Whitespace in filenames is tolerated on most systems, but not all,
and even on systems where it might be tolerated, some utilities
-might becoem confused by such whitespace.
+might become confused by such whitespace.
Many systems (DOS, VMS) cannot have more than one C<.> in their filenames.
Don't assume C<< > >> won't be the first character of a filename.
-Always use C<< < >> explicitly to open a file for reading,
-unless you want the user to be able to specify a pipe open.
+Always use C<< < >> explicitly to open a file for reading, or even
+better, use the three-arg version of open, unless you want the user to
+be able to specify a pipe open.
- open(FILE, "< $existing_file") or die $!;
+ open(FILE, '<', $existing_file) or die $!;
If filenames might use strange characters, it is safest to open it
with C<sysopen> instead of C<open>. C<open> is magic and can
translate characters like C<< > >>, C<< < >>, and C<|>, which may
be the wrong thing to do. (Sometimes, though, it's the right thing.)
+Three-arg open can also help protect against this translation in cases
+where it is undesirable.
Don't use C<:> as a part of a filename since many systems use that for
their own semantics (MacOS Classic for separating pathname components,
many networking schemes and utilities for separating the nodename and
-the pathname, and so on).
+the pathname, and so on). For the same reasons, avoid C<@>, C<;> and
+C<|>.
The I<portable filename characters> as defined by ANSI C are
0 1 2 3 4 5 6 7 8 9
. _ -
-and the "-" shouldn't be the first character.
+and the "-" shouldn't be the first character. If you want to be
+hypercorrect, stay within the 8.3 naming convention (all the files and
+directories have to be unique within one directory if their names are
+lowercased and truncated to eight characters before the C<.>, if any,
+and to three characters after the C<.>, if any). (And do not use
+C<.>s in directory names.)
=head2 System Interaction
Perl_die_where(pTHX_ char *message, STRLEN msglen)
{
STRLEN n_a;
+ IO *io;
+ MAGIC *mg;
+
if (PL_in_eval) {
I32 cxix;
register PERL_CONTEXT *cx;
}
if (!message)
message = SvPVx(ERRSV, msglen);
- {
+
+ /* if STDERR is tied, print to it instead */
+ if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
+ dSP; ENTER;
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
+ PUTBACK;
+ call_method("PRINT", G_SCALAR);
+ LEAVE;
+ }
+ else {
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
int e = errno;
s += numlen;
len += numlen;
foldbuf += numlen;
+ if (numlen >= foldlen)
+ break;
}
else
break; /* "Can't happen." */
ender = utf8_to_uvchr(foldbuf, &numlen);
if (numlen > 0) {
reguni(pRExC_state, ender, s, &numlen);
- s += numlen;
len += numlen;
+ s += numlen;
foldbuf += numlen;
+ if (numlen >= foldlen)
+ break;
}
else
break;
char *l = locinput;
char *e = PL_regeol;
- if (ibcmp_utf8(s, 0, ln, do_utf8,
- l, &e, 0, UTF)) {
+ if (ibcmp_utf8(s, 0, ln, UTF,
+ l, &e, 0, do_utf8)) {
/* One more case for the sharp s:
* pack("U0U*", 0xDF) =~ /ss/i,
* the 0xC3 0x9F are the UTF-8
ok( !eval { open local $f, '<&', 'afile'; 1 }, 'local <& on non-filehandle');
like( $@, qr/Bad filehandle:\s+afile/, ' right error' );
-
{
local *F;
for (1..2) {
use Symbol;
-print "1..38\n";
+print "1..39\n";
my $fh = gensym;
use warnings;
# Special case of aliasing STDERR, which used
# to dump core when warnings were enabled
- *STDERR = *$fh;
+ local *STDERR = *$fh;
@expect = (PRINT => $ob,"some","text");
$r = print STDERR @expect[2,3];
ok($r == 1);
sub TIEARRAY {bless {}}
}
+{
+ # warnings should pass to the PRINT method of tied STDERR
+ my @received;
+
+ local *STDERR = *$fh;
+ local *Implement::PRINT = sub { @received = @_ };
+
+ $r = warn("some", "text", "\n");
+ @expect = (PRINT => $ob,"sometext\n");
+
+ Implement::compare(PRINT => @received);
+}
+
Perl_is_uni_alnum(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_alnum(tmpbuf);
}
Perl_is_uni_alnumc(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_alnumc(tmpbuf);
}
Perl_is_uni_idfirst(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_idfirst(tmpbuf);
}
Perl_is_uni_alpha(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_alpha(tmpbuf);
}
Perl_is_uni_ascii(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_ascii(tmpbuf);
}
Perl_is_uni_space(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_space(tmpbuf);
}
Perl_is_uni_digit(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_digit(tmpbuf);
}
Perl_is_uni_upper(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_upper(tmpbuf);
}
Perl_is_uni_lower(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_lower(tmpbuf);
}
Perl_is_uni_cntrl(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_cntrl(tmpbuf);
}
Perl_is_uni_graph(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_graph(tmpbuf);
}
Perl_is_uni_print(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_print(tmpbuf);
}
Perl_is_uni_punct(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_punct(tmpbuf);
}
Perl_is_uni_xdigit(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return is_utf8_xdigit(tmpbuf);
}
Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
{
U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return to_utf8_upper(tmpbuf, p, lenp);
}
Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
{
U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return to_utf8_title(tmpbuf, p, lenp);
}
Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return to_utf8_lower(tmpbuf, p, lenp);
}
Perl_to_uni_fold(pTHX_ UV c, U8* p, STRLEN *lenp)
{
U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
- uvchr_to_utf8(tmpbuf, (UV)c);
+ uvchr_to_utf8(tmpbuf, c);
return to_utf8_fold(tmpbuf, p, lenp);
}
UV
Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
{
- UV uv;
+ UV uv0, uv1, uv2;
+ U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
+ STRLEN len;
if (!*swashp)
*swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
- uv = swash_fetch(*swashp, p, TRUE);
- if (!uv) {
+ uv0 = utf8_to_uvchr(p, 0);
+ /* The NATIVE_TO_UNI() and UNI_TO_NATIVE() mappings
+ * are necessary in EBCDIC, they are redundant no-ops
+ * in ASCII-ish platforms, and hopefully optimized away. */
+ uv1 = NATIVE_TO_UNI(uv0);
+ uvuni_to_utf8(tmpbuf, uv1);
+ uv2 = swash_fetch(*swashp, tmpbuf, TRUE);
+ if (uv2) {
+ /* It was "normal" (a single character mapping). */
+ UV uv3 = UNI_TO_NATIVE(uv2);
+
+ len = uvuni_to_utf8(ustrp, uv3) - ustrp;
+ }
+ else {
+ /* It might be "special" (sometimes, but not always,
+ * a multicharacter mapping) */
HV *hv;
SV *keysv;
HE *he;
-
- uv = utf8_to_uvchr(p, 0);
-
+ SV *val;
+
if ((hv = get_hv(special, FALSE)) &&
- (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv))) &&
- (he = hv_fetch_ent(hv, keysv, FALSE, 0))) {
- SV *val = HeVAL(he);
- STRLEN len;
- char *s = SvPV(val, len);
-
- if (len > 1) {
- Copy(s, ustrp, len, U8);
+ (keysv = sv_2mortal(Perl_newSVpvf(aTHX_ "%04"UVXf, uv1))) &&
+ (he = hv_fetch_ent(hv, keysv, FALSE, 0)) &&
+ (val = HeVAL(he))) {
+ char *s;
+ U8 *d;
+
+ s = SvPV(val, len);
+ if (len == 1)
+ len = uvuni_to_utf8(ustrp, NATIVE_TO_UNI(*(U8*)s)) - ustrp;
+ else {
#ifdef EBCDIC
- {
- /* If we have EBCDIC we need to remap the
- * characters coming in from the "special"
- * (usually, but not always multicharacter)
- * mapping, since any characters in the low 256
- * are in Unicode code points, not EBCDIC.
- * --jhi */
-
- U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
- U8 *d = tmpbuf;
- U8 *t, *tend;
+ /* If we have EBCDIC we need to remap the characters
+ * since any characters in the low 256 are Unicode
+ * code points, not EBCDIC. */
+ U8 *t = (U8*)s, *tend = t + len;
+
+ d = tmpbuf;
+ if (SvUTF8(val)) {
+ STRLEN tlen = 0;
- if (SvUTF8(val)) {
- STRLEN tlen = 0;
-
- for (t = ustrp, tend = t + len;
- t < tend; t += tlen) {
- UV c = utf8_to_uvchr(t, &tlen);
-
- if (tlen > 0)
- d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
- else
- break;
+ while (t < tend) {
+ UV c = utf8_to_uvchr(t, &tlen);
+ if (tlen > 0) {
+ d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
+ t += tlen;
}
- } else {
- for (t = ustrp, tend = t + len;
- t < tend; t++)
- d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t));
+ else
+ break;
}
- len = d - tmpbuf;
- Copy(tmpbuf, ustrp, len, U8);
}
-#endif
- }
- else {
- UV c = UNI_TO_NATIVE(*(U8*)s);
- U8 *d = uvchr_to_utf8(ustrp, c);
-
- len = d - ustrp;
+ else {
+ while (t < tend)
+ d = uvchr_to_utf8(d, UNI_TO_NATIVE(*t++));
+ }
+ len = d - tmpbuf;
+ Copy(tmpbuf, ustrp, len, U8);
+#else
+ Copy(s, ustrp, len, U8);
}
- if (lenp)
- *lenp = len;
- return utf8_to_uvchr(ustrp, 0);
+#endif
+ }
+ else {
+ /* It was not "special", either. */
+ len = uvchr_to_utf8(ustrp, uv0) - ustrp;
}
- uv = NATIVE_TO_UNI(uv);
}
+
if (lenp)
- *lenp = UNISKIP(uv);
- uvuni_to_utf8(ustrp, uv);
- return uv;
+ *lenp = len;
+
+ return utf8_to_uvchr(ustrp, 0);
}
/*
if (u1)
to_utf8_fold(p1, foldbuf1, &foldlen1);
else {
- natbuf[0] = NATIVE_TO_UNI(*p1);
+ natbuf[0] = *p1;
to_utf8_fold(natbuf, foldbuf1, &foldlen1);
}
q1 = foldbuf1;
if (u2)
to_utf8_fold(p2, foldbuf2, &foldlen2);
else {
- natbuf[0] = NATIVE_TO_UNI(*p2);
+ natbuf[0] = *p2;
to_utf8_fold(natbuf, foldbuf2, &foldlen2);
}
q2 = foldbuf2;
CV *cv;
SV *msv;
STRLEN msglen;
+ IO *io;
+ MAGIC *mg;
msv = vmess(pat, args);
message = SvPV(msv, msglen);
return;
}
}
+
+ /* if STDERR is tied, use it instead */
+ if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
+ && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
+ dSP; ENTER;
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
+ PUTBACK;
+ call_method("PRINT", G_SCALAR);
+ LEAVE;
+ return;
+ }
+
{
PerlIO *serr = Perl_error_log;
This file documents the changes made to port Perl to the Stratus
VOS operating system.
+For 5.8.0:
+ Updated "config.alpha.def", "config.ga.def", "build.cm", and
+ "install_perl.cm" to use directory naming conventions that
+ are closer to the perl standard directory names.
+
+ For the first time, full perl can now be built on VOS using
+ its native Configure script and makefiles. See README.vos
+ for details.
+
For 5.7.1:
Updated "build.cm" and "compile_perl.cm" to build perl using
either cc or gcc.
&then &set_string obj .8000
&
&if &cpu& = mc68020
-&then &set_string obj2 .68k
-&else &set_string obj2 &obj&
+&then &set_string obj2 68k
+&else &set_string obj2 (substr &obj& 2)
&
&if &cpu& = mc68020
&then &set_string bindsize -size large
& &if (command_status) ^= 0 &then &return
&
!&compiler& <<perl.c &diag& &cpu& &cflags& -o perl&s& &+
- -DARCHLIB="/system/ported/perl/lib/5.7&obj2&" &+
- -DARCHLIB_EXP="/system/ported/perl/lib/5.7&obj2&" &+
- -DSITEARCH="/system/ported/perl/lib/site/5.7&obj2&" &+
- -DSITEARCH_EXP="/system/ported/perl/lib/site/5.7&obj2&"
+ -DARCHLIB="/system/ported/lib/perl5/5.8.0/&obj2&" &+
+ -DARCHLIB_EXP="/system/ported/lib/perl5/5.8.0/&obj2&" &+
+ -DSITEARCH="/system/ported/lib/perl5/site_perl/5.8.0/&obj2&" &+
+ -DSITEARCH_EXP="/system/ported/lib/perl5/site_perl/5.8.0/&obj2&" &+
+ -DARCHNAME="&obj2&"
&if (command_status) ^= 0 &then &return
!&compiler& <<perlapi.c &diag& &cpu& &cflags& -o perlapi&s&
&if (command_status) ^= 0 &then &return
&if &rebind& = 0
&then &return
&
-&if (exists -directory (master_disk)>system>tcp_os>object_library&obj2&)
-&then &set_string tcp_objlib (master_disk)>system>tcp_os>object_library&obj2&
+&if (exists -directory (master_disk)>system>tcp_os>object_library.&obj2&)
+&then &set_string tcp_objlib (master_disk)>system>tcp_os>object_library.&obj2&
&else &set_string tcp_objlib (master_disk)>system>tcp_os>object_library
&
-&if (exists -directory (master_disk)>system>stcp>object_library&obj2&)
-&then &set_string stcp_objlib (master_disk)>system>stcp>object_library&obj2&
+&if (exists -directory (master_disk)>system>stcp>object_library.&obj2&)
+&then &set_string stcp_objlib (master_disk)>system>stcp>object_library.&obj2&
&else &set_string stcp_objlib (master_disk)>system>stcp>object_library
&
-&if (exists -directory (master_disk)>system>object_library&obj2&)
-&then &set_string objlib (master_disk)>system>object_library&obj2&
+&if (exists -directory (master_disk)>system>object_library.&obj2&)
+&then &set_string objlib (master_disk)>system>object_library.&obj2&
&else &set_string objlib (master_disk)>system>object_library
&
-&if (exists -directory (master_disk)>system>c_object_library&obj2&)
-&then &set_string c_objlib (master_disk)>system>c_object_library&obj2&
+&if (exists -directory (master_disk)>system>c_object_library.&obj2&)
+&then &set_string c_objlib (master_disk)>system>c_object_library.&obj2&
&else &set_string c_objlib (master_disk)>system>c_object_library
&
-&if (exists -directory (master_disk)>system>posix_object_library&obj2&)
-&then &set_string posix_objlib (master_disk)>system>posix_object_library&obj2&
+&if (exists -directory (master_disk)>system>posix_object_library.&obj2&)
+&then &set_string posix_objlib (master_disk)>system>posix_object_library.&obj2&
&else &set_string posix_objlib (master_disk)>system>posix_object_library
&
&if &version& = alpha
$aphostname=''
$archlib=''
$archlibexp=''
-$archname='vos'
+$archname=''
$bin='/system/ported/command_library'
$binexp='/system/ported/command_library'
$byteorder='4321'
$castflags='0'
-$cf_by='Paul_Green@stratus.com'
-$cf_time='2001-06-11 02:41 UCT'
+$cf_by='Paul.Green@stratus.com'
+$cf_time='2002-02-15 20:16 UCT'
$CONFIG_SH='config.sh'
$cpp_stuff='42'
$cpplast='-'
$package='perl5'
$pidtype='pid_t'
$pm_apiversion='5.005'
-$privlib='/system/ported/perl/lib/5.7'
-$privlibexp='/system/ported/perl/lib/5.7'
+$privlib='/system/ported/lib/perl5/5.8.0'
+$privlibexp='/system/ported/lib/perl5/5.8.0'
$procselfexe=''
$prototype='define'
$ptrsize='4'
$sig_num_init='0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,0'
$sig_size='31'
$signal_t='void'
-$sitearch=''
-$sitearchexp=''
-$sitelib='/system/ported/perl/lib/site/5.7'
-$sitelibexp='/system/ported/perl/lib/site/5.7'
-$sitelib_stem='/system/ported/perl/lib/site'
+$sitearch='/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1'
+$sitearchexp='/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1'
+$sitelib='/system/ported/lib/perl5/site_perl/5.8.0'
+$sitelibexp='/system/ported/lib/perl5/site_perl/5.8.0'
+$sitelib_stem='/system/ported/lib/perl5/site_perl'
$sizesize='4'
$sizetype='size_t'
$socksizetype='int'
/*
* Package name : perl5
* Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
- * Configuration time: 2001-06-11 02:41 UCT
- * Configured by : Paul_Green@stratus.com
+ * Configuration time: 2002-02-15 20:16 UCT
+ * Configured by : Paul.Green@stratus.com
* Target system : VOS
*/
* where library files may be held under a private library, for
* instance.
*/
-#define ARCHNAME "vos" /**/
+#define ARCHNAME "" /**/
/* HAS_ATOLF:
* This symbol, if defined, indicates that the atolf routine is
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define PRIVLIB "/system/ported/perl/lib/5.7" /**/
-#define PRIVLIB_EXP "/system/ported/perl/lib/5.7" /**/
+#define PRIVLIB "/system/ported/lib/perl5/5.8.0" /**/
+#define PRIVLIB_EXP "/system/ported/lib/perl5/5.8.0" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-/*#define SITEARCH "" /**/
-/*#define SITEARCH_EXP "" /**/
+/*#define SITEARCH "/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1" /**/
+/*#define SITEARCH_EXP "/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1" /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "/system/ported/perl/lib/site/5.7" /**/
-#define SITELIB_EXP "/system/ported/perl/lib/site/5.7" /**/
-#define SITELIB_STEM "/system/ported/perl/lib/site" /**/
+#define SITELIB "/system/ported/lib/perl5/site_perl/5.8.0" /**/
+#define SITELIB_EXP "/system/ported/lib/perl5/site_perl/5.8.0" /**/
+#define SITELIB_STEM "/system/ported/lib/perl5/site_perl" /**/
/* Size_t_size:
* This symbol holds the size of a Size_t in bytes.
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
- * lib/lib.pm will automatically search in for older
+ * lib/lib.pm will automatically search in /system/ported/lib/perl5/site_perl/5.8.0/hppa1.1 for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
- * search in /system/ported/perl/lib/site/5.7 for older directories across major versions
+ * search in /system/ported/lib/perl5/site_perl/5.8.0 for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
* If defined, this macro indicates that the C compiler can handle
* function prototypes.
*/
-/* PERL_PROTO_:
+/* _:
* This macro is used to declare function parameters for folks who want
* to make declarations with prototypes using a different style than
* the above macros. Use double parentheses. For example:
*
- * int main PERL_PROTO_((int argc, char *argv[]));
+ * int main _((int argc, char *argv[]));
*/
#define CAN_PROTOTYPE /**/
#ifdef CAN_PROTOTYPE
+#define _(args) args
#else
+#define _(args) ()
#endif
/* SH_PATH:
$aphostname=''
$archlib=''
$archlibexp=''
-$archname='vos'
+$archname=''
$bin='/system/gnu_library/bin'
$binexp='/system/gnu_library/bin'
$byteorder='4321'
$castflags='0'
-$cf_by='Paul_Green@stratus.com'
-$cf_time='2001-06-11 02:46 UCT'
+$cf_by='Paul.Green@stratus.com'
+$cf_time='2002-02-15 20:16 UCT'
$CONFIG_SH='config.sh'
$cpp_stuff='42'
$cpplast='-'
$d_phostname='undef'
$d_pipe='define'
$d_poll='define'
-$d_poll='define'
$d_procselfexe='undef'
$d_pthread_atfork='undef'
$d_pthread_yield='undef'
$package='perl5'
$pidtype='pid_t'
$pm_apiversion='5.005'
-$privlib='/system/ported/perl/lib/5.7'
-$privlibexp='/system/ported/perl/lib/5.7'
+$privlib='/system/ported/lib/perl5/5.8.0'
+$privlibexp='/system/ported/lib/perl5/5.8.0'
$procselfexe=''
$prototype='define'
$ptrsize='4'
$sig_num_init='0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,0'
$sig_size='32'
$signal_t='void'
-$sitearch=''
-$sitearchexp=''
-$sitelib='/system/ported/perl/lib/site/5.7'
-$sitelibexp='/system/ported/perl/lib/site/5.7'
-$sitelib_stem='/system/ported/perl/lib/site'
+$sitearch='/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1'
+$sitearchexp='/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1'
+$sitelib='/system/ported/lib/perl5/site_perl/5.8.0'
+$sitelibexp='/system/ported/lib/perl5/site_perl/5.8.0'
+$sitelib_stem='/system/ported/lib/perl5/site_perl'
$sizesize='4'
$sizetype='size_t'
$socksizetype='int'
/*
* Package name : perl5
* Source directory : /vos_ftp_site/pub/vos/posix/(alpha|ga)/perl
- * Configuration time: 2001-06-11 02:46 UCT
- * Configured by : Paul_Green@stratus.com
+ * Configuration time: 2002-02-15 20:16 UCT
+ * Configured by : Paul.Green@stratus.com
* Target system : VOS
*/
* where library files may be held under a private library, for
* instance.
*/
-#define ARCHNAME "vos" /**/
+#define ARCHNAME "" /**/
/* HAS_ATOLF:
* This symbol, if defined, indicates that the atolf routine is
* This symbol contains the ~name expanded version of PRIVLIB, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define PRIVLIB "/system/ported/perl/lib/5.7" /**/
-#define PRIVLIB_EXP "/system/ported/perl/lib/5.7" /**/
+#define PRIVLIB "/system/ported/lib/perl5/5.8.0" /**/
+#define PRIVLIB_EXP "/system/ported/lib/perl5/5.8.0" /**/
/* PTRSIZE:
* This symbol contains the size of a pointer, so that the C preprocessor
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-/*#define SITEARCH "" /**/
-/*#define SITEARCH_EXP "" /**/
+/*#define SITEARCH "/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1" /**/
+/*#define SITEARCH_EXP "/system/ported/lib/perl5/site_perl/5.8.0/hppa1.1" /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* removed. The elements in inc_version_list (inc_version_list.U) can
* be tacked onto this variable to generate a list of directories to search.
*/
-#define SITELIB "/system/ported/perl/lib/site/5.7" /**/
-#define SITELIB_EXP "/system/ported/perl/lib/site/5.7" /**/
-#define SITELIB_STEM "/system/ported/perl/lib/site" /**/
+#define SITELIB "/system/ported/lib/perl5/site_perl/5.8.0" /**/
+#define SITELIB_EXP "/system/ported/lib/perl5/site_perl/5.8.0" /**/
+#define SITELIB_STEM "/system/ported/lib/perl5/site_perl" /**/
/* Size_t_size:
* This symbol holds the size of a Size_t in bytes.
/* PERL_XS_APIVERSION:
* This variable contains the version of the oldest perl binary
* compatible with the present perl. perl.c:incpush() and
- * lib/lib.pm will automatically search in for older
+ * lib/lib.pm will automatically search in /system/ported/lib/perl5/site_perl/5.8.0/hppa1.1 for older
* directories across major versions back to xs_apiversion.
* This is only useful if you have a perl library directory tree
* structured like the default one.
* compatible with the present perl. (That is, pure perl modules
* written for pm_apiversion will still work for the current
* version). perl.c:incpush() and lib/lib.pm will automatically
- * search in /system/ported/perl/lib/site/5.7 for older directories across major versions
+ * search in /system/ported/lib/perl5/site_perl/5.8.0 for older directories across major versions
* back to pm_apiversion. This is only useful if you have a perl
* library directory tree structured like the default one. The
* versioned site_perl library was introduced in 5.005, so that's
* If defined, this macro indicates that the C compiler can handle
* function prototypes.
*/
-/* PERL_PROTO_:
+/* _:
* This macro is used to declare function parameters for folks who want
* to make declarations with prototypes using a different style than
* the above macros. Use double parentheses. For example:
*
- * int main PERL_PROTO_((int argc, char *argv[]));
+ * int main _((int argc, char *argv[]));
*/
#define CAN_PROTOTYPE /**/
#ifdef CAN_PROTOTYPE
+#define _(args) args
#else
+#define _(args) ()
#endif
/* SH_PATH:
& Macro to install the perl components into the right directories
-& Written 00-10-24 by Paul Green (Paul_Green@stratus.com)
+& Written 00-10-24 by Paul Green (Paul.Green@stratus.com)
+& Updated 02-02-15 by Paul Green
&
&begin_parameters
cpu option(-processor)name,allow(mc68020,i80860,pa7100,pa8000),=mc68020
+ name option(-name)name,allow(perl,perl5),=perl5
&end_parameters priv
&echo command_lines
&
&if ^ (exists -directory &MDS&>ported>command_library)
&then !create_dir &MDS&>ported>command_library
&
-&if ^ (exists -directory &MDS&>ported>perl)
-&then !create_dir &MDS&>ported>perl
+&if ^ (exists -directory &MDS&>ported>lib)
+&then !create_dir &MDS&>ported>lib
&
-&if ^ (exists -directory &MDS&>ported>perl>lib)
-&then !create_dir &MDS&>ported>perl>lib
+&if ^ (exists -directory &MDS&>ported>lib>perl5)
+&then !create_dir &MDS&>ported>lib>perl5
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>5.7)
-&then !create_dir &MDS&>ported>perl>lib>5.7
+&if ^ (exists -directory &MDS&>ported>lib>perl5>5.8.0)
+&then !create_dir &MDS&>ported>lib>perl5>5.8.0
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.68k)
-&then !create_dir &MDS&>ported>perl>lib>5.7.68k
+!copy_file <lib>*.pm &MDS&>ported>lib>perl5>5.8.0>*.pm -delete
+!copy_file <lib>*.pl &MDS&>ported>lib>perl5>5.8.0>*.pl -delete
+!copy_file <lib>*.pod &MDS&>ported>lib>perl5>5.8.0>*.pod -delete
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.860)
-&then !create_dir &MDS&>ported>perl>lib>5.7.860
+&if ^ (exists -directory &MDS&>ported>lib>perl5>5.8.0>68k)
+&then !create_dir &MDS&>ported>lib>perl5>5.8.0>68k
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.7100)
-&then !create_dir &MDS&>ported>perl>lib>5.7.7100
+&if ^ (exists -directory &MDS&>ported>lib>perl5>5.8.0>860)
+&then !create_dir &MDS&>ported>lib>perl5>5.8.0>860
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>5.7.8000)
-&then !create_dir &MDS&>ported>perl>lib>5.7.8000
+&if ^ (exists -directory &MDS&>ported>lib>perl5>5.8.0>7100)
+&then !create_dir &MDS&>ported>lib>perl5>5.8.0>7100
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>site)
-&then !create_dir &MDS&>ported>perl>lib>site
+&if ^ (exists -directory &MDS&>ported>lib>perl5>5.8.0>8000)
+&then !create_dir &MDS&>ported>lib>perl5>5.8.0>8000
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7)
-&then !create_dir &MDS&>ported>perl>lib>site>5.7
+&if ^ (exists -directory &MDS&>ported>lib>perl5>site_perl)
+&then !create_dir &MDS&>ported>lib>perl5>site_perl
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.68k)
-&then !create_dir &MDS&>ported>perl>lib>site>5.7.68k
+&if ^ (exists -directory &MDS&>ported>lib>perl5>site_perl>5.8.0)
+&then !create_dir &MDS&>ported>lib>perl5>site_perl>5.8.0
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.860)
-&then !create_dir &MDS&>ported>perl>lib>site>5.7.860
+&if ^ (exists -directory &MDS&>ported>lib>perl5>site_perl>5.8.0>68k)
+&then !create_dir &MDS&>ported>lib>perl5>site_perl>5.8.0>68k
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.7100)
-&then !create_dir &MDS&>ported>perl>lib>site>5.7.7100
+&if ^ (exists -directory &MDS&>ported>lib>perl5>site_perl>5.8.0>860)
+&then !create_dir &MDS&>ported>lib>perl5>site_perl>5.8.0>860
&
-&if ^ (exists -directory &MDS&>ported>perl>lib>site>5.7.8000)
-&then !create_dir &MDS&>ported>perl>lib>site>5.7.8000
+&if ^ (exists -directory &MDS&>ported>lib>perl5>site_perl>5.8.0>7100)
+&then !create_dir &MDS&>ported>lib>perl5>site_perl>5.8.0>7100
&
-!copy_dir <lib &MDS&>ported>perl>lib>5.7 -delete
+&if ^ (exists -directory &MDS&>ported>lib>perl5>site_perl>5.8.0>8000)
+&then !create_dir &MDS&>ported>lib>perl5>site_perl>5.8.0>8000
&
-!copy_file obj&obj&>perl.pm &MDS&>ported>command_library>perl.pm.new -delete
-!rename &MDS&>ported>command_library>perl.pm *.(date).(time) -delete
-!rename &MDS&>ported>command_library>perl.pm.new perl.pm -delete
+!copy_file obj&obj&>perl.pm &MDS&>ported>command_library>&name&.pm.new -delete
+!rename &MDS&>ported>command_library>&name&.pm *.(date).(time) -delete
+!rename &MDS&>ported>command_library>&name&.pm.new &name&.pm -delete
projects / p5sagit/p5-mst-13.2.git / commitdiff