From: Nick Ing-Simmons Date: Mon, 18 Feb 2002 09:09:23 +0000 (+0000) Subject: Integrate mainline X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8e0fc1cdff8c4d07f11a5b0bd5056e1acbe2a68a;p=p5sagit%2Fp5-mst-13.2.git Integrate mainline p4raw-id: //depot/perlio@14740 --- diff --git a/Changes b/Changes index 83f0a07..e416484 100644 --- a/Changes +++ b/Changes @@ -31,6 +31,168 @@ or any other branch. 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 + 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 + 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?= + 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 + 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ä" + 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 + 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 + 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 + 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 + 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 + 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: + Branch: perl + ! Makefile.SH +____________________________________________________________________________ +[ 14682] By: jhi on 2002/02/13 15:50:37 + Log: Subject: Re: perl@14647 + From: "H.Merijn Brand" + 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; diff --git a/Configure b/Configure index a56d56a..f372c92 100755 --- a/Configure +++ b/Configure @@ -20,7 +20,7 @@ # $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$$ <checkcc +cat <trygcc $startsh EOS -cat <<'EOSC' >>checkcc +cat <<'EOSC' >>trygcc case "$cc" in '') ;; *) $rm -f try try.* @@ -2291,15 +2291,37 @@ EOM esac fi fi + fi + $rm -f try try.* + ;; +esac +EOSC + +cat <checkcc +$startsh +EOS +cat <<'EOSC' >>checkcc +case "$cc" in +'') ;; +*) $rm -f try try.* + $cat >try.c <&4 <&4 + fi + $cat >&4 < try.c @@ -8678,9 +8706,13 @@ char *myname = "qgcvt"; #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"; @@ -8723,6 +8755,21 @@ int main() 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); @@ -8761,31 +8808,59 @@ int main() 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 @@ -8800,12 +8875,19 @@ for xxx_convert in $xxx_list; do 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))' ;; @@ -8813,11 +8895,15 @@ qgcvt) d_Gconvert='qgcvt((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 diff --git a/MANIFEST b/MANIFEST index 33ad2f6..5154679 100644 --- a/MANIFEST +++ b/MANIFEST @@ -194,6 +194,8 @@ ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture 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 @@ -330,11 +332,18 @@ ext/Encode/Encode/symbol.enc Encode table 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 @@ -349,10 +358,15 @@ ext/Encode/Makefile.PL Encode extension makefile writer 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 @@ -633,8 +647,8 @@ ext/threads/shared/t/sv_simple.t thread shared variables 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. @@ -1838,6 +1852,9 @@ os2/OS2/Process/Makefile.PL system() constants in a module 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 diff --git a/Porting/Glossary b/Porting/Glossary index eb2fe3d..2b59210 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -691,6 +691,10 @@ d_Gconvert (d_gconvert.U): 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 diff --git a/Porting/config.sh b/Porting/config.sh index 5248db2..e2aca12 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # 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 @@ -63,7 +63,7 @@ ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_ 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' @@ -687,7 +687,7 @@ patchlevel='7' 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' @@ -856,7 +856,7 @@ vendorlibexp='' 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' @@ -886,7 +886,7 @@ PERL_SUBVERSION=2 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"' diff --git a/Porting/config_H b/Porting/config_H index ab44615..536c66e 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * 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 */ @@ -3421,18 +3421,18 @@ * 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: diff --git a/README.vos b/README.vos index 61b2fa2..016d6c9 100644 --- a/README.vos +++ b/README.vos @@ -8,9 +8,10 @@ README.vos - Perl for Stratus VOS =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 -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 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 @@ -21,16 +22,103 @@ ftp://ftp.stratus.com/pub/vos/posix/ga/ga.html. Instructions for 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 @@ -102,19 +190,19 @@ execute on VOS Release 12 or earlier. 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 @@ -135,68 +223,72 @@ execute on the PA7100, PA8000, PA8500 and PA8600 processors, and 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. @@ -240,12 +332,17 @@ can't guarantee I'll be able to answer them. There are some 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 diff --git a/configpm b/configpm index 6216f85..9f1a2e1 100755 --- a/configpm +++ b/configpm @@ -277,6 +277,17 @@ if ($OS2::is_aout) { $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 <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 @@ -1969,6 +1970,7 @@ sub listop { 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") { @@ -3056,7 +3058,8 @@ sub escape_str { # ASCII, UTF8 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; } diff --git a/ext/Encode/CN/CN.pm b/ext/Encode/CN/CN.pm new file mode 100644 index 0000000..2aca19b --- /dev/null +++ b/ext/Encode/CN/CN.pm @@ -0,0 +1,8 @@ +package Encode::CN; +use Encode; +our $VERSION = '0.02'; +use XSLoader; +XSLoader::load('Encode::CN',$VERSION); + +1; +__END__ diff --git a/ext/Encode/EUC_JP/Makefile.PL b/ext/Encode/CN/Makefile.PL similarity index 94% copy from ext/Encode/EUC_JP/Makefile.PL copy to ext/Encode/CN/Makefile.PL index b5b3746..37d19e0 100644 --- a/ext/Encode/EUC_JP/Makefile.PL +++ b/ext/Encode/CN/Makefile.PL @@ -2,13 +2,13 @@ use 5.7.2; 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..", diff --git a/ext/Encode/EUC_JP/Japanese.pm b/ext/Encode/EUC_JP/Japanese.pm deleted file mode 100644 index 2e81a3e..0000000 --- a/ext/Encode/EUC_JP/Japanese.pm +++ /dev/null @@ -1,8 +0,0 @@ -package Encode::Japanese; -use Encode; -our $VERSION = '0.01'; -use XSLoader; -XSLoader::load('Encode::Japanese',$VERSION); -1; -__END__ - diff --git a/ext/Encode/Encode.pm b/ext/Encode/Encode.pm index e804583..45daffa 100644 --- a/ext/Encode/Encode.pm +++ b/ext/Encode/Encode.pm @@ -1,6 +1,6 @@ package Encode; use strict; -our $VERSION = '0.30'; +our $VERSION = '0.40'; require DynaLoader; require Exporter; diff --git a/ext/Encode/JP/JP.pm b/ext/Encode/JP/JP.pm new file mode 100644 index 0000000..f3d4998 --- /dev/null +++ b/ext/Encode/JP/JP.pm @@ -0,0 +1,11 @@ +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__ diff --git a/ext/Encode/EUC_JP/Makefile.PL b/ext/Encode/JP/Makefile.PL similarity index 94% copy from ext/Encode/EUC_JP/Makefile.PL copy to ext/Encode/JP/Makefile.PL index b5b3746..33c34c9 100644 --- a/ext/Encode/EUC_JP/Makefile.PL +++ b/ext/Encode/JP/Makefile.PL @@ -2,13 +2,12 @@ use 5.7.2; 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..", diff --git a/ext/Encode/KR/KR.pm b/ext/Encode/KR/KR.pm new file mode 100644 index 0000000..34c512a --- /dev/null +++ b/ext/Encode/KR/KR.pm @@ -0,0 +1,11 @@ +package Encode::KR; +use Encode; +our $VERSION = '0.02'; +use XSLoader; +XSLoader::load('Encode::KR',$VERSION); + +1; +__END__ + +todo: + diff --git a/ext/Encode/EUC_JP/Makefile.PL b/ext/Encode/KR/Makefile.PL similarity index 94% copy from ext/Encode/EUC_JP/Makefile.PL copy to ext/Encode/KR/Makefile.PL index b5b3746..85afa59 100644 --- a/ext/Encode/EUC_JP/Makefile.PL +++ b/ext/Encode/KR/Makefile.PL @@ -2,13 +2,11 @@ use 5.7.2; 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..", diff --git a/ext/Encode/MANIFEST b/ext/Encode/MANIFEST index bbeee2b..3f6487c 100644 --- a/ext/Encode/MANIFEST +++ b/ext/Encode/MANIFEST @@ -1,4 +1,6 @@ -Encode.xs +CN/Makefile.PL +CN/CN.pm +Encode/euc-jp.ucm Encode/11643-1.enc Encode/11643-2.enc Encode/2022-cn.enc @@ -42,7 +44,6 @@ Encode/8859-8.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 @@ -93,6 +94,7 @@ Encode/gb12345.enc Encode/gb1988.enc Encode/gb2312.enc Encode/gsm0338.enc +Encode/HZ.enc Encode/ir-197.enc Encode/jis0201.enc Encode/jis0208.enc @@ -119,33 +121,53 @@ Encode/macTurkish.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 diff --git a/ext/Encode/EUC_JP/Makefile.PL b/ext/Encode/TW/Makefile.PL similarity index 94% rename from ext/Encode/EUC_JP/Makefile.PL rename to ext/Encode/TW/Makefile.PL index b5b3746..ca25098 100644 --- a/ext/Encode/EUC_JP/Makefile.PL +++ b/ext/Encode/TW/Makefile.PL @@ -2,13 +2,11 @@ use 5.7.2; 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..", diff --git a/ext/Encode/TW/TW.pm b/ext/Encode/TW/TW.pm new file mode 100644 index 0000000..689db95 --- /dev/null +++ b/ext/Encode/TW/TW.pm @@ -0,0 +1,10 @@ +package Encode::TW; +use Encode; +our $VERSION = '0.02'; +use XSLoader; +XSLoader::load('Encode::TW',$VERSION); + +1; +__END__ + +todo: HZ (Escape-based) diff --git a/ext/Encode/lib/Encode/JP/Constants.pm b/ext/Encode/lib/Encode/JP/Constants.pm new file mode 100644 index 0000000..baa0b2b --- /dev/null +++ b/ext/Encode/lib/Encode/JP/Constants.pm @@ -0,0 +1,63 @@ +# +# $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; + diff --git a/ext/Encode/lib/Encode/JP/H2Z.pm b/ext/Encode/lib/Encode/JP/H2Z.pm new file mode 100644 index 0000000..d18fc9f --- /dev/null +++ b/ext/Encode/lib/Encode/JP/H2Z.pm @@ -0,0 +1,168 @@ +# +# $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; diff --git a/ext/Encode/lib/Encode/JP/ISO_2022_JP.pm b/ext/Encode/lib/Encode/JP/ISO_2022_JP.pm new file mode 100644 index 0000000..d8c8fb7 --- /dev/null +++ b/ext/Encode/lib/Encode/JP/ISO_2022_JP.pm @@ -0,0 +1,34 @@ +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__ diff --git a/ext/Encode/lib/Encode/JP/JIS.pm b/ext/Encode/lib/Encode/JP/JIS.pm new file mode 100644 index 0000000..6ee3c84 --- /dev/null +++ b/ext/Encode/lib/Encode/JP/JIS.pm @@ -0,0 +1,74 @@ +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__ diff --git a/ext/Encode/lib/Encode/JP/Tr.pm b/ext/Encode/lib/Encode/JP/Tr.pm new file mode 100644 index 0000000..28aac78 --- /dev/null +++ b/ext/Encode/lib/Encode/JP/Tr.pm @@ -0,0 +1,90 @@ +# +# $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; diff --git a/ext/Encode/t/Encode.t b/ext/Encode/t/Encode.t index ffc4780..28becb4 100644 --- a/ext/Encode/t/Encode.t +++ b/ext/Encode/t/Encode.t @@ -1,12 +1,13 @@ 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 diff --git a/ext/Encode/t/Japanese.t b/ext/Encode/t/JP.t similarity index 71% rename from ext/Encode/t/Japanese.t rename to ext/Encode/t/JP.t index 20f5b25..e9799da 100644 --- a/ext/Encode/t/Japanese.t +++ b/ext/Encode/t/JP.t @@ -8,12 +8,15 @@ BEGIN { } $| = 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')); @@ -24,12 +27,12 @@ my $utf = File::Spec->catfile($dir,"table.utf8"); 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; @@ -38,12 +41,12 @@ close($src); 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; @@ -54,11 +57,11 @@ ok(compare($euc,$rnd) == 0); is($enc->name,'euc-jp'); print "# src :encoding test\n"; -open(my $src,":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; @@ -72,9 +75,9 @@ SKIP: { #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>) diff --git a/ext/Encode/t/japanese.pl b/ext/Encode/t/japanese.pl new file mode 100644 index 0000000..c0fe3ca --- /dev/null +++ b/ext/Encode/t/japanese.pl @@ -0,0 +1,6 @@ +# +use strict; +#use blib; +use Encode::Japanese; + +# print join("\n", Encode::encodings()),"\n"; diff --git a/hints/os2.sh b/hints/os2.sh index 8633f26..9c1355c 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -472,3 +472,4 @@ esac # Now go back cd ../.. +cp os2/*.t t/lib diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index f89842a..d657166 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -252,15 +252,21 @@ END # 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 <&2 NOTE: You are using GNU ld(1). GNU ld(1) might not build Perl. If you diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 3d3ab76..e81c997 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -1,6 +1,6 @@ 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; @@ -12,10 +12,11 @@ use FileHandle; 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 @@ -333,9 +334,10 @@ sub ping_tcp 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); } @@ -634,7 +636,7 @@ __END__ 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 diff --git a/lib/Net/Ping/CHANGES b/lib/Net/Ping/CHANGES index 65b03ed..172692d 100644 --- a/lib/Net/Ping/CHANGES +++ b/lib/Net/Ping/CHANGES @@ -1,6 +1,13 @@ 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 diff --git a/lib/Net/Ping/README b/lib/Net/Ping/README index bde09f0..5e7d055 100644 --- a/lib/Net/Ping/README +++ b/lib/Net/Ping/README @@ -1,7 +1,7 @@ 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; diff --git a/lib/Net/Ping/t/110_icmp_inst.t b/lib/Net/Ping/t/110_icmp_inst.t index 9553f84..bf27289 100644 --- a/lib/Net/Ping/t/110_icmp_inst.t +++ b/lib/Net/Ping/t/110_icmp_inst.t @@ -15,7 +15,9 @@ plan tests => 2; # 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"; diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index c61e7d5..9df3172 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -435,10 +435,9 @@ sub pod2html { END_OF_BLOCK print HTML < -head> + $title$csslink diff --git a/lib/Pod/Text/Overstrike.pm b/lib/Pod/Text/Overstrike.pm index bd4c379..8b19fb4 100644 --- a/lib/Pod/Text/Overstrike.pm +++ b/lib/Pod/Text/Overstrike.pm @@ -1,5 +1,5 @@ # 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 30-Nov-2000 # (based on Pod::Text::Color by Russ Allbery ) @@ -36,7 +36,7 @@ use vars qw(@ISA $VERSION); # 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; ############################################################################## @@ -109,8 +109,12 @@ sub wrap { 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; diff --git a/lib/Tie/Memoize.pm b/lib/Tie/Memoize.pm index 0b3d320..3059f3c 100644 --- a/lib/Tie/Memoize.pm +++ b/lib/Tie/Memoize.pm @@ -2,6 +2,7 @@ use strict; package Tie::Memoize; use Tie::Hash; our @ISA = 'Tie::ExtraHash'; +our $VERSION = '1.0'; our $exists_token = \undef; diff --git a/makedef.pl b/makedef.pl index 2d7057b..c6a5355 100644 --- a/makedef.pl +++ b/makedef.pl @@ -334,6 +334,9 @@ elsif ($PLATFORM eq 'os2') { Perl_hab_GET loadByOrdinal pExtFCN + os2error + ResetWinError + CroakWinError )]); } elsif ($PLATFORM eq 'MacOS') { diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL index c141757..6a59d1f 100644 --- a/os2/OS2/Process/Makefile.PL +++ b/os2/OS2/Process/Makefile.PL @@ -32,7 +32,7 @@ sub create_constants { '--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"), diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm index 3015430..29e4d9b 100644 --- a/os2/OS2/Process/Process.pm +++ b/os2/OS2/Process/Process.pm @@ -1,24 +1,33 @@ 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 @@ -62,15 +71,24 @@ BEGIN { 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 @@ -94,26 +112,46 @@ BEGIN { 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. "; } @@ -122,6 +160,29 @@ sub AUTOLOAD { 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] } @@ -134,7 +195,7 @@ sub swTitle_set_sw { change_entry(@sw); } -sub swTitle_set { +sub swTitle_set ($) { my (@sw) = process_entry(); swTitle_set_sw(shift, @sw); } @@ -145,19 +206,25 @@ sub winTitle_set_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; @@ -179,6 +246,7 @@ sub swentry_hexpand ($) { } sub process_hentry { swentry_hexpand(process_swentry(@_)) } +sub process_hwnd { process_hentry()->{owner_hwnd} } my $swentry_size = swentry_size(); @@ -214,14 +282,53 @@ sub change_entryh ($) { # 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; @@ -554,11 +661,16 @@ changes a process entry, arguments are the same as process_entry() returns. Similar to change_entry(), but takes a hash reference as an argument. +=item process_hwnd() + +returns the C 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 @@ -569,8 +681,29 @@ This is a limitation of OS/2, in such a case $^E is set to 372 (type 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 + +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 + +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 + +sets text of the titlebar and task switch menu of the current process' window +via direct manipulation of the windows' texts. =item C @@ -614,42 +747,61 @@ important restriction on ownership is that owner should be created by 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 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 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 -gets "a text content" of a window. +gets "a text content" of a window. Requires (morphing to) PM. =item C -sets "a text content" of a window. +sets "a text content" of a window. Requires (morphing to) PM. -=item C +=item C<($x, $y, $flags, $width, $height, $behind, @rest) = WindowPos($hwnd)> gets window position info as 8 integers (of C), 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 constants. + +=item C<$hash = hWindowPos($hwnd)> + +gets window position info as a hash reference; the keys are C. -=item C +Example: + + exit unless $hash->{flags} & SWP_MAXIMIZE; # Maximized + +=item C 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 +=item C -gets I and I of the process associated to the window. +Same as C, but takes the position from keys C 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 and I of the process associated to the window. =item C @@ -662,51 +814,102 @@ constant. =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 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 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 + +gets the active subwindow's handle for $parentHwnd or desktop. +Returns FALSE if none. + +=item C + +sets the active subwindow's handle for $parentHwnd or desktop. Requires (morphing to) PM. =item C Set visible/hidden flag of the window. Default: $show is TRUE. +=item C + +Set window visibility state flag for the window for subsequent drawing. +No actual drawing is done at this moment. Use C +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 of the window style.) + +=item C + +Set the window enabled state. Default: $enable is TRUE. + +Results in C 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 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 - /* 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)> @@ -716,10 +919,11 @@ gets the next kid in the list. Gets 0 on error or when the list ends. 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) = @_; @@ -752,7 +956,7 @@ return a window handle of a child of $hwnd with the given $id. =item C 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. @@ -809,11 +1013,27 @@ item list when beginning is reached. =back +=item ResetWinError() + +Resets $^E. One may need to call it before the C-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); @@ -825,23 +1045,199 @@ nest with internal ones being NOPs. =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 gives C<< behind => HWND_TOP >>? =head1 $^E @@ -851,6 +1247,37 @@ which returns something other than a boolean, it is impossible to 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) are exportable. Note that these +symbols live in package C, they are not available +by full name through C! + + 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 diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs index 159ef49..1e75951 100644 --- a/os2/OS2/Process/Process.xs +++ b/os2/OS2/Process/Process.xs @@ -245,6 +245,8 @@ file_type(char *path) 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, @@ -253,44 +255,85 @@ DeclFuncByORD(ULONG, myWinSetWindowText, ORD_WinSetWindowText, (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) @@ -298,31 +341,25 @@ 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; } @@ -332,9 +369,7 @@ QueryWindowSWP_(HWND hwnd) { SWP swp; - if (!pWinQueryWindowPos) - AssignFuncPByORD(pWinQueryWindowPos, ORD_WinQueryWindowPos); - if (CheckWinError(pWinQueryWindowPos(hwnd, &swp))) + if (!QueryWindowPos(hwnd, &swp)) croak("WinQueryWindowPos() error"); return swp; } @@ -348,112 +383,24 @@ QueryWindowSWP(HWND hwnd) } 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; @@ -474,7 +421,7 @@ fill_swentry(SWENTRY *swentryp, HWND hwnd, PID pid) 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); @@ -899,8 +846,16 @@ sidOf(int pid) 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) @@ -939,6 +894,7 @@ swentry_expand( SV *sv ) 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 ) @@ -949,6 +905,7 @@ sesmgr_title_set(s) SV * process_swentry(unsigned long pid = getpid(), unsigned long hwnd = NULLHANDLE); + PROTOTYPE: DISABLE int swentry_size() @@ -956,6 +913,9 @@ swentry_size() SV * swentries_list() +void +ResetWinError() + int WindowText_set(unsigned long hwndFrame, char *title) @@ -966,10 +926,15 @@ bool 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) @@ -981,7 +946,13 @@ unsigned long 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) @@ -993,12 +964,38 @@ unsigned long 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() @@ -1035,6 +1032,21 @@ process_codepages() 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 @@ -1044,35 +1056,40 @@ 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 @@ -1087,6 +1104,30 @@ sidOf(int pid = getpid()) 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) + diff --git a/os2/OS2/Process/t/os2_process.t b/os2/OS2/Process/t/os2_process.t new file mode 100644 index 0000000..f171047 --- /dev/null +++ b/os2/OS2/Process/t/os2_process.t @@ -0,0 +1,504 @@ +#! /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; +} diff --git a/os2/OS2/Process/t/os2_process_kid.t b/os2/OS2/Process/t/os2_process_kid.t new file mode 100644 index 0000000..7551d41 --- /dev/null +++ b/os2/OS2/Process/t/os2_process_kid.t @@ -0,0 +1,64 @@ +#! /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" } diff --git a/os2/OS2/Process/t/os2_process_text.t b/os2/OS2/Process/t/os2_process_text.t new file mode 100644 index 0000000..7367327 --- /dev/null +++ b/os2/OS2/Process/t/os2_process_text.t @@ -0,0 +1,52 @@ +#! /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 diff --git a/os2/os2.c b/os2/os2.c index 8a32ee4..38da198 100644 --- a/os2/os2.c +++ b/os2/os2.c @@ -276,10 +276,25 @@ static const struct { {&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_*. */ @@ -378,7 +393,7 @@ get_sysinfo(ULONG pid, ULONG flags) 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); @@ -1467,6 +1482,20 @@ os2error(int rc) 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) { @@ -1561,8 +1590,9 @@ Perl_Register_MQ(int serve) 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. */ @@ -2194,6 +2224,78 @@ XS(XS_Cwd_extLibpath_set) 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 @@ -2291,6 +2393,7 @@ Xs_OS2_init(pTHX) 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 diff --git a/os2/os2_base.t b/os2/os2_base.t index ceaeb3f..bb4735a 100644 --- a/os2/os2_base.t +++ b/os2/os2_base.t @@ -1,3 +1,53 @@ +#!/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(); @@ -36,7 +86,7 @@ print "ok 10\n"; 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"; diff --git a/os2/os2ish.h b/os2/os2ish.h index 034fe82..d1c45ad 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -480,15 +480,30 @@ void init_PMWIN_entries(void); /* 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)) @@ -559,6 +574,21 @@ enum entries_ordinals { 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 }; @@ -577,6 +607,44 @@ enum entries_ordinals { #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); diff --git a/patchlevel.h b/patchlevel.h index 437471b..4586af5 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -79,7 +79,7 @@ #if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT) static char *local_patches[] = { NULL - ,"DEVEL14680" + ,"DEVEL14709" ,NULL }; diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod index 9326a03..0f678f1 100644 --- a/pod/perlfaq3.pod +++ b/pod/perlfaq3.pod @@ -1,6 +1,6 @@ =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 @@ -832,6 +832,9 @@ For example: 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""" @@ -850,8 +853,7 @@ characters as control characters. 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.] diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod index f93b624..80aad94 100644 --- a/pod/perlfaq5.pod +++ b/pod/perlfaq5.pod @@ -1,6 +1,6 @@ =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 @@ -607,24 +607,18 @@ For more information, see also the new L if you have it =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? diff --git a/pod/perlport.pod b/pod/perlport.pod index df30415..8d229d6 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -332,25 +332,29 @@ first 8 characters. 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 instead of C. C 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 as defined by ANSI C are @@ -359,7 +363,12 @@ The I 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 diff --git a/pp_ctl.c b/pp_ctl.c index 9dbd525..14a48c6 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1224,6 +1224,9 @@ OP * 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; @@ -1303,7 +1306,19 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) } 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; diff --git a/regcomp.c b/regcomp.c index 7e1e6bd..53b1698 100644 --- a/regcomp.c +++ b/regcomp.c @@ -3193,6 +3193,8 @@ tryagain: s += numlen; len += numlen; foldbuf += numlen; + if (numlen >= foldlen) + break; } else break; /* "Can't happen." */ @@ -3221,9 +3223,11 @@ tryagain: 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; diff --git a/regexec.c b/regexec.c index 8bd2284..900b491 100644 --- a/regexec.c +++ b/regexec.c @@ -2380,8 +2380,8 @@ S_regmatch(pTHX_ regnode *prog) 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 diff --git a/t/io/open.t b/t/io/open.t index cb8aea3..f49ba10 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -201,7 +201,6 @@ EOC ok( !eval { open local $f, '<&', 'afile'; 1 }, 'local <& on non-filehandle'); like( $@, qr/Bad filehandle:\s+afile/, ' right error' ); - { local *F; for (1..2) { diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t index 7ae3351..257a613 100755 --- a/t/op/tiehandle.t +++ b/t/op/tiehandle.t @@ -77,7 +77,7 @@ package main; use Symbol; -print "1..38\n"; +print "1..39\n"; my $fh = gensym; @@ -160,7 +160,7 @@ ok($r == 1); 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); @@ -217,3 +217,16 @@ 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); +} + diff --git a/utf8.c b/utf8.c index 71aaf8a..b1bdeb6 100644 --- a/utf8.c +++ b/utf8.c @@ -841,7 +841,7 @@ bool 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); } @@ -849,7 +849,7 @@ bool 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); } @@ -857,7 +857,7 @@ bool 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); } @@ -865,7 +865,7 @@ bool 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); } @@ -873,7 +873,7 @@ bool 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); } @@ -881,7 +881,7 @@ bool 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); } @@ -889,7 +889,7 @@ bool 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); } @@ -897,7 +897,7 @@ bool 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); } @@ -905,7 +905,7 @@ bool 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); } @@ -913,7 +913,7 @@ bool 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); } @@ -921,7 +921,7 @@ bool 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); } @@ -929,7 +929,7 @@ bool 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); } @@ -937,7 +937,7 @@ bool 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); } @@ -945,7 +945,7 @@ bool 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); } @@ -953,7 +953,7 @@ UV 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); } @@ -961,7 +961,7 @@ UV 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); } @@ -969,7 +969,7 @@ UV 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); } @@ -977,7 +977,7 @@ UV 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); } @@ -1287,78 +1287,85 @@ to the hash is by Perl_to_utf8_case(). 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); } /* @@ -1841,7 +1848,7 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const 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; @@ -1851,7 +1858,7 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const 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; diff --git a/util.c b/util.c index 33dcf19..26b63d0 100644 --- a/util.c +++ b/util.c @@ -1356,6 +1356,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + IO *io; + MAGIC *mg; msv = vmess(pat, args); message = SvPV(msv, msglen); @@ -1388,6 +1390,20 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) 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; diff --git a/vos/Changes b/vos/Changes index 640db49..407b258 100644 --- a/vos/Changes +++ b/vos/Changes @@ -1,6 +1,15 @@ 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. diff --git a/vos/build.cm b/vos/build.cm index 20592ad..5eb56a2 100644 --- a/vos/build.cm +++ b/vos/build.cm @@ -50,8 +50,8 @@ &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 @@ -154,10 +154,11 @@ & &if (command_status) ^= 0 &then &return & !&compiler& <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 diff --git a/vos/config.alpha.def b/vos/config.alpha.def index 996a0c7..250c5e1 100644 --- a/vos/config.alpha.def +++ b/vos/config.alpha.def @@ -2,13 +2,13 @@ $alignbytes='8' $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='-' @@ -458,8 +458,8 @@ $otherlibdirs='' $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' @@ -479,11 +479,11 @@ $sig_name_init='"ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO" $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' diff --git a/vos/config.alpha.h b/vos/config.alpha.h index bce8eb5..7d5145e 100644 --- a/vos/config.alpha.h +++ b/vos/config.alpha.h @@ -13,8 +13,8 @@ /* * 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 */ @@ -989,7 +989,7 @@ * 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 @@ -2959,8 +2959,8 @@ * 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 @@ -3063,8 +3063,8 @@ * 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. @@ -3086,9 +3086,9 @@ * 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. @@ -3324,7 +3324,7 @@ /* 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. @@ -3343,7 +3343,7 @@ * 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 @@ -3417,16 +3417,18 @@ * 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: diff --git a/vos/config.ga.def b/vos/config.ga.def index ec18320..7bef8fb 100644 --- a/vos/config.ga.def +++ b/vos/config.ga.def @@ -2,13 +2,13 @@ $alignbytes='8' $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='-' @@ -192,7 +192,6 @@ $d_perl_otherlibdirs='undef' $d_phostname='undef' $d_pipe='define' $d_poll='define' -$d_poll='define' $d_procselfexe='undef' $d_pthread_atfork='undef' $d_pthread_yield='undef' @@ -459,8 +458,8 @@ $otherlibdirs='' $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' @@ -480,11 +479,11 @@ $sig_name_init='"ZERO","ABRT","FPE","ILL","INT","SEGV","TERM","USR1","USR2","IO" $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' diff --git a/vos/config.ga.h b/vos/config.ga.h index ef9cc07..876d5eb 100644 --- a/vos/config.ga.h +++ b/vos/config.ga.h @@ -13,8 +13,8 @@ /* * 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 */ @@ -989,7 +989,7 @@ * 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 @@ -2959,8 +2959,8 @@ * 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 @@ -3063,8 +3063,8 @@ * 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. @@ -3086,9 +3086,9 @@ * 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. @@ -3324,7 +3324,7 @@ /* 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. @@ -3343,7 +3343,7 @@ * 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 @@ -3417,16 +3417,18 @@ * 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: diff --git a/vos/install_perl.cm b/vos/install_perl.cm index 95fe064..a54f68b 100644 --- a/vos/install_perl.cm +++ b/vos/install_perl.cm @@ -1,8 +1,10 @@ & 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 & @@ -23,47 +25,49 @@ &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 *.pm &MDS&>ported>lib>perl5>5.8.0>*.pm -delete +!copy_file *.pl &MDS&>ported>lib>perl5>5.8.0>*.pl -delete +!copy_file *.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 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