diff options
169 files changed, 41736 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/eg/cgi/internal_links.cgi b/gnu/usr.bin/perl/eg/cgi/internal_links.cgi new file mode 100644 index 00000000000..4806966842d --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/internal_links.cgi @@ -0,0 +1,33 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +# We generate a regular HTML file containing a very long list +# and a popup menu that does nothing except to show that we +# don't lose the state information. +print $query->header; +print $query->start_html("Internal Links Example"); +print "<H1>Internal Links Example</H1>\n"; +print "Click <cite>Submit Query</cite> to create a state. Then scroll down and", + " click on any of the <cite>Jump to top</cite> links. This is not very exciting."; + +print "<A NAME=\"start\"></A>\n"; # an anchor point at the top + +# pick a default starting value; +$query->param('amenu','FOO1') unless $query->param('amenu'); + +print $query->startform; +print $query->popup_menu('amenu',[('FOO1'..'FOO9')]); +print $query->submit,$query->endform; + +# We create a long boring list for the purposes of illustration. +$myself = $query->self_url; +print "<OL>\n"; +for (1..100) { + print qq{<LI>List item #$_ <A HREF="$myself#start">Jump to top</A>\n}; +} +print "</OL>\n"; + +print $query->end_html; + diff --git a/gnu/usr.bin/perl/eg/cgi/javascript.cgi b/gnu/usr.bin/perl/eg/cgi/javascript.cgi new file mode 100644 index 00000000000..91c2b9e6482 --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/javascript.cgi @@ -0,0 +1,105 @@ +#!/usr/local/bin/perl + +# This script illustrates how to use JavaScript to validate fill-out +# forms. +use CGI qw(:standard); + +# Here's the javascript code that we include in the document. +$JSCRIPT=<<EOF; + // validate that the user is the right age. Return + // false to prevent the form from being submitted. + function validateForm() { + var today = new Date(); + var birthday = validateDate(document.form1.birthdate); + if (birthday == 0) { + document.form1.birthdate.focus() + document.form1.birthdate.select(); + return false; + } + var milliseconds = today.getTime()-birthday; + var years = milliseconds/(1000 * 60 * 60 * 24 * 365.25); + if ((years > 20) || (years < 5)) { + alert("You must be between the ages of 5 and 20 to submit this form"); + document.form1.birthdate.focus(); + document.form1.birthdate.select(); + return false; + } + // Since we've calculated the age in years already, + // we might as well send it up to our CGI script. + document.form1.age.value=Math.floor(years); + return true; + } + + // make sure that the contents of the supplied + // field contain a valid date. + function validateDate(element) { + var date = Date.parse(element.value); + if (0 == date) { + alert("Please enter date in format MMM DD, YY"); + element.focus(); + element.select(); + } + return date; + } + + // Compliments, compliments + function doPraise(element) { + if (element.checked) { + self.status=element.value + " is an excellent choice!"; + return true; + } else { + return false; + } + } + + function checkColor(element) { + var color = element.options[element.selectedIndex].text; + if (color == "blonde") { + if (confirm("Is it true that blondes have more fun?")) + alert("Darn. That leaves me out."); + } else + alert(color + " is a fine choice!"); + } +EOF + ; + +# here's where the execution begins +print header; +print start_html(-title=>'Personal Profile',-script=>$JSCRIPT); + +print h1("Big Brother Wants to Know All About You"), + strong("Note: "),"This page uses JavaScript and requires ", + "Netscape 2.0 or higher to do anything special."; + +&print_prompt(); +print hr; +&print_response() if param; +print end_html; + +sub print_prompt { + print start_form(-name=>'form1', + -onSubmit=>"return validateForm()"),"\n"; + print "Birthdate (e.g. Jan 3, 1972): ", + textfield(-name=>'birthdate', + -onBlur=>"validateDate(this)"),"<p>\n"; + print "Sex: ",radio_group(-name=>'gender', + -value=>[qw/male female/], + -onClick=>"doPraise(this)"),"<p>\n"; + print "Hair color: ",popup_menu(-name=>'color', + -value=>[qw/brunette blonde red gray/], + -default=>'red', + -onChange=>"checkColor(this)"),"<p>\n"; + print hidden(-name=>'age',-value=>0); + print submit(); + print end_form; +} + +sub print_response { + import_names('Q'); + print h2("Your profile"), + "You claim to be a ",b($Q::age)," year old ",b($Q::color,$Q::gender),".", + "You should be ashamed of yourself for lying so ", + "blatantly to big brother!", + hr; +} + diff --git a/gnu/usr.bin/perl/eg/cgi/monty.cgi b/gnu/usr.bin/perl/eg/cgi/monty.cgi new file mode 100644 index 00000000000..b7c0f6a8f60 --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/monty.cgi @@ -0,0 +1,83 @@ +#!/usr/local/bin/perl + +use CGI; + +$query = new CGI; + +print $query->header; +print $query->start_html("Example CGI.pm Form"); +print "<H1> Example CGI.pm Form</H1>\n"; +&print_prompt($query); +&do_work($query); +&print_tail; +print $query->end_html; + +sub print_prompt { + my($query) = @_; + + print $query->start_multipart_form; + print "<EM>What's your name?</EM><BR>"; + print $query->textfield('name'); + print $query->checkbox('Not my real name'); + + print "<P><EM>Where can you find English Sparrows?</EM><BR>"; + print $query->checkbox_group( + -name=>'Sparrow locations', + -values=>[England,France,Spain,Asia,Hoboken], + -linebreak=>'yes', + -defaults=>[England,Asia]); + + print "<P><EM>How far can they fly?</EM><BR>", + $query->radio_group( + -name=>'how far', + -values=>['10 ft','1 mile','10 miles','real far'], + -default=>'1 mile'); + + print "<P><EM>What's your favorite color?</EM> "; + print $query->popup_menu(-name=>'Color', + -values=>['black','brown','red','yellow'], + -default=>'red'); + + print $query->hidden('Reference','Monty Python and the Holy Grail'); + + print "<P><EM>What have you got there?</EM><BR>"; + print $query->scrolling_list( + -name=>'possessions', + -values=>['A Coconut','A Grail','An Icon', + 'A Sword','A Ticket'], + -size=>5, + -multiple=>'true'); + + print "<P><EM>Any parting comments?</EM><BR>"; + print $query->textarea(-name=>'Comments', + -rows=>10, + -columns=>50); + + print "<P>",$query->reset; + print $query->submit('Action','Shout'); + print $query->submit('Action','Scream'); + print $query->endform; + print "<HR>\n"; + } + +sub do_work { + my($query) = @_; + my(@values,$key); + + print "<H2>Here are the current settings in this form</H2>"; + + foreach $key ($query->param) { + print "<STRONG>$key</STRONG> -> "; + @values = $query->param($key); + print join(", ",@values),"<BR>\n"; + } +} + +sub print_tail { + print <<END; +<HR> +<ADDRESS>Lincoln D. Stein</ADDRESS><BR> +<A HREF="/">Home Page</A> +END + ; +} diff --git a/gnu/usr.bin/perl/eg/cgi/multiple_forms.cgi b/gnu/usr.bin/perl/eg/cgi/multiple_forms.cgi new file mode 100644 index 00000000000..b38bf93e96c --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/multiple_forms.cgi @@ -0,0 +1,54 @@ +#!/usr/local/bin/perl + +use CGI; + +$query = new CGI; +print $query->header; +print $query->start_html('Multiple Forms'); +print "<H1>Multiple Forms</H1>\n"; + +# Print the first form +print $query->startform; +$name = $query->remote_user || 'anonymous@' . $query->remote_host; + +print "What's your name? ",$query->textfield('name',$name,50); +print "<P>What's the combination?<P>", + $query->checkbox_group('words',['eenie','meenie','minie','moe']); +print "<P>What's your favorite color? ", + $query->popup_menu('color',['red','green','blue','chartreuse']), + "<P>"; +print $query->submit('form_1','Send Form 1'); +print $query->endform; + +# Print the second form +print "<HR>\n"; +print $query->startform; +print "Some radio buttons: ",$query->radio_group('radio buttons', + [qw{one two three four five}],'three'),"\n"; +print "<P>What's the password? ",$query->password_field('pass','secret'); +print $query->defaults,$query->submit('form_2','Send Form 2'),"\n"; +print $query->endform; + +print "<HR>\n"; + +$query->import_names('Q'); +if ($Q::form_1) { + print "<H2>Form 1 Submitted</H2>\n"; + print "Your name is <EM>$Q::name</EM>\n"; + print "<P>The combination is: <EM>{",join(",",@Q::words),"}</EM>\n"; + print "<P>Your favorite color is <EM>$Q::color</EM>\n"; +} elsif ($Q::form_2) { + print <<EOF; +<H2>Form 2 Submitted</H2> +<P>The value of the radio buttons is <EM>$Q::radio_buttons</EM> +<P>The secret password is <EM>$Q::pass</EM> +EOF + ; +} +print qq{<P><A HREF="./">Other examples</A>}; +print qq{<P><A HREF="../cgi_docs.html">Go to the documentation</A>}; + +print $query->end_html; + + + diff --git a/gnu/usr.bin/perl/eg/cgi/nph-clock.cgi b/gnu/usr.bin/perl/eg/cgi/nph-clock.cgi new file mode 100644 index 00000000000..55a2fbe545c --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/nph-clock.cgi @@ -0,0 +1,18 @@ +#!/usr/local/bin/perl -w + +use CGI::Push qw(:standard :html3); + +do_push(-next_page=>\&draw_time,-delay=>1); + +sub draw_time { + my $time = `/bin/date`; + return start_html('Tick Tock'), + div({-align=>CENTER}, + h1('Virtual Clock'), + h2($time) + ), + hr, + a({-href=>'index.html'},'More examples'), + end_html(); +} + diff --git a/gnu/usr.bin/perl/eg/cgi/popup.cgi b/gnu/usr.bin/perl/eg/cgi/popup.cgi new file mode 100644 index 00000000000..88cea1da9c4 --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/popup.cgi @@ -0,0 +1,32 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; +print $query->header; +print $query->start_html('Popup Window'); + + +if (!$query->param) { + print "<H1>Ask your Question</H1>\n"; + print $query->startform(-target=>'_new'); + print "What's your name? ",$query->textfield('name'); + print "<P>What's the combination?<P>", + $query->checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','moe']); + + print "<P>What's your favorite color? ", + $query->popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + "<P>"; + print $query->submit; + print $query->endform; + +} else { + print "<H1>And the Answer is...</H1>\n"; + print "Your name is <EM>",$query->param(name),"</EM>\n"; + print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n"; + print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n"; +} +print qq{<P><A HREF="cgi_docs.html">Go to the documentation</A>}; +print $query->end_html; diff --git a/gnu/usr.bin/perl/eg/cgi/save_state.cgi b/gnu/usr.bin/perl/eg/cgi/save_state.cgi new file mode 100644 index 00000000000..be79051bd64 --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/save_state.cgi @@ -0,0 +1,67 @@ +#!/usr/local/bin/perl + +use CGI; +$query = new CGI; + +print $query->header; +print $query->start_html("Save and Restore Example"); +print "<H1>Save and Restore Example</H1>\n"; + +# Here's where we take action on the previous request +&save_parameters($query) if $query->param('action') eq 'SAVE'; +$query = &restore_parameters($query) if $query->param('action') eq 'RESTORE'; + +# Here's where we create the form +print $query->startform; +print "Popup 1: ",$query->popup_menu('popup1',[qw{red green purple magenta orange chartreuse brown}]),"\n"; +print "Popup 2: ",$query->popup_menu('popup2',[qw{lion tiger bear zebra potto wildebeest frog emu gazelle}]),"\n"; +print "<P>"; +$default_name = $query->remote_addr . '.sav'; +print "Save/restore state from file: ",$query->textfield('savefile',$default_name),"\n"; +print "<P>"; +print $query->submit('action','SAVE'),$query->submit('action','RESTORE'); +print "<P>",$query->defaults; +print $query->endform; + +# Here we print out a bit at the end +print $query->end_html; + +sub save_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,">$filename")) { + $query->save(FILE); + close FILE; + print "<STRONG>State has been saved to file $filename</STRONG>\n"; + print "<P>If you remember this name you can restore the state later.\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't write to file $filename: $!\n"; + } +} + +sub restore_parameters { + local($query) = @_; + local($filename) = &clean_name($query->param('savefile')); + if (open(FILE,$filename)) { + $query = new CGI(FILE); # Throw out the old query, replace it with a new one + close FILE; + print "<STRONG>State has been restored from file $filename</STRONG>\n"; + } else { + print "<STRONG>Error:</STRONG> couldn't restore file $filename: $!\n"; + } + return $query; +} + + +# Very important subroutine -- get rid of all the naughty +# metacharacters from the file name. If there are, we +# complain bitterly and die. +sub clean_name { + local($name) = @_; + unless ($name=~/^[\w\._\-]+$/) { + print "<STRONG>$name has naughty characters. Only "; + print "alphanumerics are allowed. You can't use absolute names.</STRONG>"; + die "Attempt to use naughty characters"; + } + return "WORLD_WRITABLE/$name"; +} diff --git a/gnu/usr.bin/perl/eg/cgi/tryit.cgi b/gnu/usr.bin/perl/eg/cgi/tryit.cgi new file mode 100644 index 00000000000..83c620c3e43 --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/tryit.cgi @@ -0,0 +1,37 @@ +#!/usr/local/bin/perl + +use CGI ':standard'; + +print header; +print start_html('A Simple Example'), + h1('A Simple Example'), + start_form, + "What's your name? ",textfield('name'), + p, + "What's the combination?", + p, + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','minie']), + p, + "What's your favorite color? ", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']), + p, + submit, + end_form, + hr; + +if (param()) { + print + "Your name is: ",em(param('name')), + p, + "The keywords are: ",em(join(", ",param('words'))), + p, + "Your favorite color is: ",em(param('color')), + hr; +} +print a({href=>'../cgi_docs.html'},'Go to the documentation'); +print end_html; + + diff --git a/gnu/usr.bin/perl/eg/cgi/wilogo.gif.uu b/gnu/usr.bin/perl/eg/cgi/wilogo.gif.uu new file mode 100644 index 00000000000..a183bc02d5b --- /dev/null +++ b/gnu/usr.bin/perl/eg/cgi/wilogo.gif.uu @@ -0,0 +1,14 @@ +begin 644 wilogo.gif +M1TE&.#=A7@!$`(```'X2F?___RP`````7@!$```"_D2.J<#MKF)ZU,A3,[OO +M(IUY']A%9"6AW$F)+#2]Y:BNLF6_\;WMH<?#I72^VP+D"@*)F&"O25KRDM&B +M[%C-7;4_J)*6'4ZE&O`W8"1OQ5UGPWRBIKDPM!MW9J]-[;LUKL;$5W.'YQ3( +M(O<&-^>F*(A55\BX%UEI^;<VB0BH1RFX2=<IELE4^*0'N?-I>OJ8N%(*Z^4G +M.OJJ>8HZ.(>;JRMD><E[!KQHB^3;:APL6Z8\RKPK/)O:*-WLW&7]*\UYR]J) +M?<P=1MR-_6VN76,WGAV^32W^3CZ_SCY3;W__C-R^CU^\%M#T!9PVL(ZZ&>X" +M%A1XSM]!A?T8/C0T$1XMJG\B&G+,"-&C/(VS0(842;`)M'S>_OE8F#"=2S#* +M8LHLAS'D1Y,42UGY9O,F-T:X@@JEE@D1RW>/D@8R.DZ-+*E0CQ:9JJ5JU!SQ +MR&BU2D.;E*4'ER0TNY%G2A/Y.G[=VG%81+5K_UG$21<A6;=YP9'5B++O7:@7 +M\]J5]]?DX7:)%<]5%=B/55>-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+ +(KPA.EJ```#L` +` +end diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs new file mode 100644 index 00000000000..2b7563764e1 --- /dev/null +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs @@ -0,0 +1,153 @@ +/* dl_cygwin32.xs + * + * Platform: Win32 (Windows NT/Windows 95) + * Author: Wei-Yuen Tan (wyt@hip.com) + * Created: A warm day in June, 1995 + * + * Modified: + * August 23rd 1995 - rewritten after losing everything when I + * wiped off my NT partition (eek!) + */ +/* Modified from the original dl_win32.xs to work with cygwin32 + -John Cerney 3/26/97 +*/ +/* Porting notes: + +I merely took Paul's dl_dlopen.xs, took out extraneous stuff and +replaced the appropriate SunOS calls with the corresponding Win32 +calls. + +*/ + +#define WIN32_LEAN_AND_MEAN +// Defines from windows needed for this function only. Can't include full +// Cygwin32 windows headers because of problems with CONTEXT redefinition +// Removed logic to tell not dynamically load static modules. It is assumed that all +// modules are dynamically built. This should be similar to the behavoir on sunOS. +// Leaving in the logic would have required changes to the standard perlmain.c code +// +// // Includes call a dll function to initialize it's impure_ptr. +#include <stdio.h> +void (*impure_setupptr)(struct _reent *); // pointer to the impure_setup routine + +//#include <windows.h> +#define LOAD_WITH_ALTERED_SEARCH_PATH (8) +typedef void *HANDLE; +typedef HANDLE HINSTANCE; +#define STDCALL __attribute__ ((stdcall)) +typedef int STDCALL (*FARPROC)(); + +HINSTANCE +STDCALL +LoadLibraryExA( + char* lpLibFileName, + HANDLE hFile, + unsigned int dwFlags + ); +unsigned int +STDCALL +GetLastError( + void + ); +FARPROC +STDCALL +GetProcAddress( + HINSTANCE hModule, + char* lpProcName + ); + +#include <string.h> + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* SaveError() etc */ + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void * +dl_load_file(filename,flags=0) + char * filename + int flags + PREINIT: + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + + RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; + + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL){ + SaveError("%d",GetLastError()) ; + } + else{ + // setup the dll's impure_ptr: + impure_setupptr = GetProcAddress(RETVAL, "impure_setup"); + if( impure_setupptr == NULL){ + printf( + "Cygwin32 dynaloader error: could not load impure_setup symbol\n"); + RETVAL = NULL; + } + else{ + // setup the DLLs impure_ptr: + (*impure_setupptr)(_impure_ptr); + sv_setiv( ST(0), (IV)RETVAL); + } + } + + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%d",GetLastError()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/gnu/usr.bin/perl/ext/IO/IO.pm b/gnu/usr.bin/perl/ext/IO/IO.pm new file mode 100644 index 00000000000..1ba05ca9165 --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/IO.pm @@ -0,0 +1,36 @@ +# + +package IO; + +=head1 NAME + +IO - load various IO modules + +=head1 SYNOPSIS + + use IO; + +=head1 DESCRIPTION + +C<IO> provides a simple mechanism to load all of the IO modules at one go. +Currently this includes: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + +For more information on any of these modules, please see its respective +documentation. + +=cut + +use IO::Handle; +use IO::Seekable; +use IO::File; +use IO::Pipe; +use IO::Socket; + +1; + diff --git a/gnu/usr.bin/perl/ext/IO/IO.xs b/gnu/usr.bin/perl/ext/IO/IO.xs new file mode 100644 index 00000000000..e558d5c4e0a --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/IO.xs @@ -0,0 +1,288 @@ +#include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 +#include "perl.h" +#include "XSUB.h" + +#ifdef I_UNISTD +# include <unistd.h> +#endif +#ifdef I_FCNTL +# include <fcntl.h> +#endif + +#ifdef PerlIO +typedef int SysRet; +typedef PerlIO * InputStream; +typedef PerlIO * OutputStream; +#else +#define PERLIO_IS_STDIO 1 +typedef int SysRet; +typedef FILE * InputStream; +typedef FILE * OutputStream; +#endif + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static bool +constant(name, pval) +char *name; +IV *pval; +{ + switch (*name) { + case '_': + if (strEQ(name, "_IOFBF")) +#ifdef _IOFBF + { *pval = _IOFBF; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "_IOLBF")) +#ifdef _IOLBF + { *pval = _IOLBF; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "_IONBF")) +#ifdef _IONBF + { *pval = _IONBF; return TRUE; } +#else + return FALSE; +#endif + break; + case 'S': + if (strEQ(name, "SEEK_SET")) +#ifdef SEEK_SET + { *pval = SEEK_SET; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_CUR")) +#ifdef SEEK_CUR + { *pval = SEEK_CUR; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_END")) +#ifdef SEEK_END + { *pval = SEEK_END; return TRUE; } +#else + return FALSE; +#endif + break; + } + + return FALSE; +} + + +MODULE = IO PACKAGE = IO::Seekable PREFIX = f + +SV * +fgetpos(handle) + InputStream handle + CODE: + if (handle) { + Fpos_t pos; +#ifdef PerlIO + PerlIO_getpos(handle, &pos); +#else + fgetpos(handle, &pos); +#endif + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } + else { + ST(0) = &sv_undef; + errno = EINVAL; + } + +SysRet +fsetpos(handle, pos) + InputStream handle + SV * pos + CODE: + char *p; + if (handle && (p = SvPVx(pos, na)) && na == sizeof(Fpos_t)) +#ifdef PerlIO + RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); +#else + RETVAL = fsetpos(handle, (Fpos_t*)p); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +MODULE = IO PACKAGE = IO::File PREFIX = f + +SV * +new_tmpfile(packname = "IO::File") + char * packname + PREINIT: + OutputStream fp; + GV *gv; + CODE: +#ifdef PerlIO + fp = PerlIO_tmpfile(); +#else + fp = tmpfile(); +#endif + gv = (GV*)SvREFCNT_inc(newGVgen(packname)); + hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); + if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) { + ST(0) = sv_2mortal(newRV((SV*)gv)); + sv_bless(ST(0), gv_stashpv(packname, TRUE)); + SvREFCNT_dec(gv); /* undo increment in newRV() */ + } + else { + ST(0) = &sv_undef; + SvREFCNT_dec(gv); + } + +MODULE = IO PACKAGE = IO::Handle PREFIX = f + +SV * +constant(name) + char * name + CODE: + IV i; + if (constant(name, &i)) + ST(0) = sv_2mortal(newSViv(i)); + else + ST(0) = &sv_undef; + +int +ungetc(handle, c) + InputStream handle + int c + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_ungetc(handle, c); +#else + RETVAL = ungetc(c, handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +ferror(handle) + InputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_error(handle); +#else + RETVAL = ferror(handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +clearerr(handle) + InputStream handle + CODE: + if (handle) { +#ifdef PerlIO + PerlIO_clearerr(handle); +#else + clearerr(handle); +#endif + RETVAL = 0; + } + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +untaint(handle) + SV * handle + CODE: +#ifdef IOf_UNTAINT + IO * io; + io = sv_2io(handle); + if (io) { + IoFLAGS(io) |= IOf_UNTAINT; + RETVAL = 0; + } + else { +#endif + RETVAL = -1; + errno = EINVAL; +#ifdef IOf_UNTAINT + } +#endif + OUTPUT: + RETVAL + +SysRet +fflush(handle) + OutputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_flush(handle); +#else + RETVAL = Fflush(handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +void +setbuf(handle, buf) + OutputStream handle + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; + CODE: + if (handle) +#ifdef PERLIO_IS_STDIO + setbuf(handle, buf); +#else + not_here("IO::Handle::setbuf"); +#endif + +SysRet +setvbuf(handle, buf, type, size) + OutputStream handle + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; + int type + int size + CODE: +/* Should check HAS_SETVBUF once Configure tests for that */ +#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) + if (!handle) /* Try input stream. */ + handle = IoIFP(sv_2io(ST(0))); + if (handle) + RETVAL = setvbuf(handle, buf, type, size); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); +#endif + OUTPUT: + RETVAL + + diff --git a/gnu/usr.bin/perl/ext/IO/Makefile.PL b/gnu/usr.bin/perl/ext/IO/Makefile.PL new file mode 100644 index 00000000000..4a34be61fbb --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'IO', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes', # XXX remove later? + VERSION_FROM => 'lib/IO/Handle.pm', + XS_VERSION => 1.15 +); diff --git a/gnu/usr.bin/perl/ext/IO/README b/gnu/usr.bin/perl/ext/IO/README new file mode 100644 index 00000000000..e855afade40 --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/README @@ -0,0 +1,4 @@ +This directory contains files from the IO distribution maintained by +Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify +any files in this directory then please forward him a patch for only +the files in this directory. diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm new file mode 100644 index 00000000000..de7fabc6f25 --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm @@ -0,0 +1,167 @@ +# + +package IO::File; + +=head1 NAME + +IO::File - supply object methods for filehandles + +=head1 SYNOPSIS + + use IO::File; + + $fh = new IO::File; + if ($fh->open("< file")) { + print <$fh>; + $fh->close; + } + + $fh = new IO::File "> file"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new IO::File "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new IO::File "file", O_WRONLY|O_APPEND; + if (defined $fh) { + print $fh "corge\n"; + + $pos = $fh->getpos; + $fh->setpos($pos); + + undef $fh; # automatically closes the file + } + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ([ ARGS ] ) + +Creates a C<IO::File>. If it receives any parameters, they are passed to +the method C<open>; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C<IO::File> opened for read/write on a newly created temporary +file. On systems where this is possible, the temporary file is anonymous +(i.e. it is unlinked after creation, but held open). If the temporary +file cannot be created or opened, the C<IO::File> object is destroyed. +Otherwise, it is returned to the caller. + +=back + +=head1 METHODS + +=over 4 + +=item open( FILENAME [,MODE [,PERMS]] ) + +C<open> accepts one, two or three parameters. With one parameter, +it is just a front end for the built-in C<open> function. With two +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode, optionally followed by a file permission value. + +If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator. + +If C<IO::File::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +For convenience, C<IO::File::import> tries to import the O_XXX +constants from the Fcntl module. If dynamic loading is not available, +this may fail, but the rest of IO::File will still work. + +=back + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::Seekable> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>. + +=cut + +require 5.000; +use strict; +use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; + +require Exporter; +require DynaLoader; + +@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); + +$VERSION = "1.06021"; + +@EXPORT = @IO::Seekable::EXPORT; + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + + +################################################ +## Constructor +## + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::File"; + @_ >= 0 && @_ <= 3 + or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; + my $fh = $class->SUPER::new(); + if (@_) { + $fh->open(@_) + or return undef; + } + $fh; +} + +################################################ +## Open +## + +sub open { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; + my ($fh, $file) = @_; + if (@_ > 2) { + my ($mode, $perms) = @_[2, 3]; + if ($mode =~ /^\d+$/) { + defined $perms or $perms = 0666; + return sysopen($fh, $file, $mode, $perms); + } + $file = './' . $file if $file =~ m{\A[^\\/\w]}; + $file = IO::Handle::_open_mode_string($mode) . " $file\0"; + } + open($fh, $file); +} + +1; diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm new file mode 100644 index 00000000000..39e32f05abb --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm @@ -0,0 +1,544 @@ + +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for I/O handles + +=head1 SYNOPSIS + + use IO::Handle; + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDIN),"r")) { + print $fh->getline; + $fh->close; + } + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDOUT),"w")) { + $fh->print("Some text\n"); + } + + use IO::Handle '_IOLBF'; + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + undef $fh; # automatically closes the file if it's open + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::Handle> is the base class for all other IO handle classes. It is +not intended that objects of C<IO::Handle> would be created directly, +but instead C<IO::Handle> is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C<FileHandle> package, then I suggest you read the documentation +for C<IO::File> + +A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package) + +=head1 CONSTRUCTOR + +=over 4 + +=item new () + +Creates a new C<IO::Handle> object. + +=item new_from_fd ( FD, MODE ) + +Creates a C<IO::Handle> like C<new> does. +It requires two parameters, which are passed to the method C<fdopen>; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Handle> methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + eof + read + truncate + stat + print + printf + sysread + syswrite + +See L<perlvar> for complete descriptions of each of the following +supported C<IO::Handle> methods: + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + +Furthermore, for doing normal I/O you might need these: + +=over + +=item $fh->fdopen ( FD, MODE ) + +C<fdopen> is like an ordinary C<open> except that its first parameter +is not a filename but rather a file handle name, a IO::Handle object, +or a file descriptor number. + +=item $fh->opened + +Returns true if the object is currently a valid file descriptor. + +=item $fh->getline + +This works like <$fh> described in L<perlop/"I/O Operators"> +except that it's more readable and can be safely called in an +array context but still returns just one line. + +=item $fh->getlines + +This works like <$fh> when called in an array context to +read all the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=item $fh->ungetc ( ORD ) + +Pushes a character with the given ordinal value back onto the given +handle's input stream. + +=item $fh->write ( BUF, LEN [, OFFSET }\] ) + +This C<write> is like C<write> found in C, that is it is the +opposite of read. The wrapper for the perl C<write> function is +called C<format_write>. + +=item $fh->flush + +Flush the given handle's buffer. + +=item $fh->error + +Returns a true value if the given handle has experienced any errors +since it was opened or since the last call to C<clearerr>. + +=item $fh->clearerr + +Clear the given handle's error indicator. + +=back + +If the C functions setbuf() and/or setvbuf() are available, then +C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering +policy for an IO::Handle. The calling sequences for the Perl functions +are the same as their C counterparts--including the constants C<_IOFBF>, +C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter +specifies a scalar variable to use as a buffer. WARNING: A variable +used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any +way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called +again, or memory corruption may result! Note that you need to import +the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. + +Lastly, there is a special method for working under B<-T> and setuid/gid +scripts: + +=over + +=item $fh->untaint + +Marks the object as taint-clean, and as such data read from it will also +be considered taint-clean. Note that this is a very trusting action to +take, and appropriate consideration for the data source and potential +vulnerability should be kept in mind. + +=back + +=head1 NOTE + +A C<IO::Handle> object is a GLOB reference. Some modules that +inherit from C<IO::Handle> may want to keep object related variables +in the hash table part of the GLOB. In an attempt to prevent modules +trampling on each other I propose the that any such module should prefix +its variables with its own name separated by _'s. For example the IO::Socket +module keeps a C<timeout> variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::File> + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C<IO::Handle>, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C<IO::Handle> and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> + +=cut + +require 5.000; +use strict; +use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = "1.1504"; +$XS_VERSION = "1.15"; + +@EXPORT_OK = qw( + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + + print + printf + getline + getlines + + SEEK_SET + SEEK_CUR + SEEK_END + _IOFBF + _IOLBF + _IONBF +); + + +################################################ +## Interaction with the XS. +## + +require DynaLoader; +@IO::ISA = qw(DynaLoader); +bootstrap IO $XS_VERSION; + +sub AUTOLOAD { + if ($AUTOLOAD =~ /::(_?[a-z])/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + my $constname = $AUTOLOAD; + $constname =~ s/.*:://; + my $val = constant($constname); + defined $val or croak "$constname is not a valid IO::Handle macro"; + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + + +################################################ +## Constructors, destructors. +## + +sub new { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 1 or croak "usage: new $class"; + my $fh = gensym; + bless $fh, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; + my $fh = gensym; + shift; + IO::Handle::fdopen($fh, @_) + or return undef; + bless $fh, $class; +} + +# +# There is no need for DESTROY to do anything, because when the +# last reference to an IO object is gone, Perl automatically +# closes its associated files (if any). However, to avoid any +# attempts to autoload DESTROY, we here define it to do nothing. +# +sub DESTROY {} + + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1</ + or $mode =~ s/^w(\+?)$/$1>/ + or $mode =~ s/^a(\+?)$/$1>>/ + or croak "IO::Handle: bad open mode: $mode"; + $mode; +} + +sub fdopen { + @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; + my ($fh, $fd, $mode) = @_; + local(*GLOB); + + if (ref($fd) && "".$fd =~ /GLOB\(/o) { + # It's a glob reference; Alias it as we cannot get name of anon GLOBs + my $n = qualify(*GLOB); + *GLOB = *{*$fd}; + $fd = $n; + } elsif ($fd =~ m#^\d+$#) { + # It's an FD number; prefix with "=". + $fd = "=$fd"; + } + + open($fh, _open_mode_string($mode) . '&' . $fd) + ? $fh : undef; +} + +sub close { + @_ == 1 or croak 'usage: $fh->close()'; + my($fh) = @_; + + close($fh); +} + +################################################ +## Normal I/O functions. +## + +# flock +# select + +sub opened { + @_ == 1 or croak 'usage: $fh->opened()'; + defined fileno($_[0]); +} + +sub fileno { + @_ == 1 or croak 'usage: $fh->fileno()'; + fileno($_[0]); +} + +sub getc { + @_ == 1 or croak 'usage: $fh->getc()'; + getc($_[0]); +} + +sub eof { + @_ == 1 or croak 'usage: $fh->eof()'; + eof($_[0]); +} + +sub print { + @_ or croak 'usage: $fh->print([ARGS])'; + my $this = shift; + print $this @_; +} + +sub printf { + @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])'; + my $this = shift; + printf $this @_; +} + +sub getline { + @_ == 1 or croak 'usage: $fh->getline'; + my $this = shift; + return scalar <$this>; +} + +*gets = \&getline; # deprecated + +sub getlines { + @_ == 1 or croak 'usage: $fh->getline()'; + wantarray or + croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline'; + my $this = shift; + return <$this>; +} + +sub truncate { + @_ == 2 or croak 'usage: $fh->truncate(LEN)'; + truncate($_[0], $_[1]); +} + +sub read { + @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])'; + read($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub sysread { + @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])'; + sysread($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub write { + @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])'; + local($\) = ""; + print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); +} + +sub syswrite { + @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; + syswrite($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub stat { + @_ == 1 or croak 'usage: $fh->stat()'; + stat($_[0]); +} + +################################################ +## State modification functions. +## + +sub autoflush { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $|; + $| = @_ > 1 ? $_[1] : 1; + $prev; +} + +sub output_field_separator { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $,; + $, = $_[1] if @_ > 1; + $prev; +} + +sub output_record_separator { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $\; + $\ = $_[1] if @_ > 1; + $prev; +} + +sub input_record_separator { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $/; + $/ = $_[1] if @_ > 1; + $prev; +} + +sub input_line_number { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} + +sub format_page_number { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $^; + $^ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_line_break_characters { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $:; + $: = $_[1] if @_ > 1; + $prev; +} + +sub format_formfeed { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $^L; + $^L = $_[1] if @_ > 1; + $prev; +} + +sub formline { + my $fh = shift; + my $picture = shift; + local($^A) = $^A; + local($\) = ""; + formline($picture, @_); + print $fh $^A; +} + +sub format_write { + @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )'; + if (@_ == 2) { + my ($fh, $fmt) = @_; + my $oldfmt = $fh->format_name($fmt); + write($fh); + $fh->format_name($oldfmt); + } else { + write($_[0]); + } +} + +sub fcntl { + @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = fcntl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +sub ioctl { + @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = ioctl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +1; diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm new file mode 100644 index 00000000000..ae6d9a547e2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm @@ -0,0 +1,239 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Pipe; + +require 5.000; + +use IO::Handle; +use strict; +use vars qw($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.0901"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + # Close in child: + fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + $fh->close; + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader()'; + my $me = shift; + my $fh = ${*$me}[0]; + my $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer()'; + my $me = shift; + my $fh = ${*$me}[1]; + my $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +use vars qw(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + +=head1 NAME + +IO::pipe - supply object methods for pipes + +=head1 SYNOPSIS + + use IO::Pipe; + + $pipe = new IO::Pipe; + + if($pid = fork()) { # Parent + $pipe->reader(); + + while(<$pipe> { + .... + } + + } + elsif(defined $pid) { # Child + $pipe->writer(); + + print $pipe .... + } + + or + + $pipe = new IO::Pipe; + + $pipe->reader(qw(ls -l)); + + while(<$pipe>) { + .... + } + +=head1 DESCRIPTION + +C<IO::Pipe> provides an interface to createing pipes between +processes. + +=head1 CONSTRCUTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates a C<IO::Pipe>, which is a reference to a newly created symbol +(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two +arguments, which should be objects blessed into C<IO::Handle>, or a +subclass thereof. These two objects will be used for the system call +to C<pipe>. If no arguments are given then method C<handles> is called +on the new C<IO::Pipe> object. + +These two handles are held in the array part of the GLOB until either +C<reader> or C<writer> is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the reading end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the writing end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item handles () + +This method is called during construction by C<IO::Pipe::new> +on the newly created C<IO::Pipe> object. It returns an array of two objects +blessed into C<IO::Pipe::End>, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L<IO::Handle> + +=head1 AUTHOR + +Graham Barr <bodg@tiuk.ti.com> + +=head1 COPYRIGHT + +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=cut diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm new file mode 100644 index 00000000000..91c381a61e9 --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm @@ -0,0 +1,68 @@ +# + +package IO::Seekable; + +=head1 NAME + +IO::Seekable - supply seek based methods for I/O objects + +=head1 SYNOPSIS + + use IO::Seekable; + package IO::Something; + @ISA = qw(IO::Seekable); + +=head1 DESCRIPTION + +C<IO::Seekable> does not have a constuctor of its own as is intended to +be inherited by other C<IO::Handle> based objects. It provides methods +which allow seeking of the file descriptors. + +If the C functions fgetpos() and fsetpos() are available, then +C<IO::File::getpos> returns an opaque value that represents the +current position of the IO::File, and C<IO::File::setpos> uses +that value to return to a previously visited position. + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Seekable> methods, which are just front ends for the +corresponding built-in functions: + + seek + tell + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::File> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt> + +=cut + +require 5.000; +use Carp; +use strict; +use vars qw($VERSION @EXPORT @ISA); +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +require Exporter; + +@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +@ISA = qw(Exporter); + +$VERSION = "1.06"; + +sub seek { + @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; + seek($_[0], $_[1], $_[2]); +} + +sub tell { + @_ == 1 or croak 'usage: $fh->tell()'; + tell($_[0]); +} + +1; diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm new file mode 100644 index 00000000000..dea684a62ed --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm @@ -0,0 +1,371 @@ +# IO::Select.pm +# +# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +# software; you can redistribute it and/or modify it under the same terms +# as Perl itself. + +package IO::Select; + +=head1 NAME + +IO::Select - OO interface to the select system call + +=head1 SYNOPSIS + + use IO::Select; + + $s = IO::Select->new(); + + $s->add(\*STDIN); + $s->add($some_handle); + + @ready = $s->can_read($timeout); + + @ready = IO::Select->new(@handles)->read(0); + +=head1 DESCRIPTION + +The C<IO::Select> package implements an object approach to the system C<select> +function call. It allows the user to see what IO handles, see L<IO::Handle>, +are ready for reading, writing or have an error condition pending. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HANDLES ] ) + +The constructor creates a new object and optionally initialises it with a set +of handles. + +=back + +=head1 METHODS + +=over 4 + +=item add ( HANDLES ) + +Add the list of handles to the C<IO::Select> object. It is these values that +will be returned when an event occurs. C<IO::Select> keeps these values in a +cache which is indexed by the C<fileno> of the handle, so if more than one +handle with the same C<fileno> is specified then only the last one is cached. + +Each handle can be an C<IO::Handle> object, an integer or an array +reference where the first element is a C<IO::Handle> or an integer. + +=item remove ( HANDLES ) + +Remove all the given handles from the object. This method also works +by the C<fileno> of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C<fileno> + +=item exists ( HANDLE ) + +Returns a true value (actually the handle itself) if it is present. +Returns undef otherwise. + +=item handles + +Return an array of all registered handles. + +=item can_read ( [ TIMEOUT ] ) + +Return an array of handles that are ready for reading. C<TIMEOUT> is +the maximum amount of time to wait before returning an empty list. If +C<TIMEOUT> is not given and any handles are registered then the call +will block. + +=item can_write ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that can be written to. + +=item has_error ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an error +condition, for example EOF. + +=item count () + +Returns the number of handles that the object will check for when +one of the C<can_> methods is called or the object is passed to +the C<select> static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) + +C<select> is a static method, that is you call it with the package +name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> +or C<IO::Select> objects. C<TIMEOUT> is optional and has the same +effect as for the core select call. + +The result will be an array of 3 elements, each a reference to an array +which will hold the handles that are ready for reading, writing and have +error conditions respectively. Upon error an empty array is returned. + +=back + +=head1 EXAMPLE + +Here is a short example which shows how C<IO::Select> could be used +to write a server which communicates with several sockets while also +listening for more connections on a listen socket + + use IO::Select; + use IO::Socket; + + $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); + $sel = new IO::Select( $lsn ); + + while(@ready = $sel->can_read) { + foreach $fh (@ready) { + if($fh == $lsn) { + # Create a new socket + $new = $lsn->accept; + $sel->add($new); + } + else { + # Process socket + + # Maybe we have finished with the socket + $sel->remove($fh); + $fh->close; + } + } + } + +=head1 AUTHOR + +Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=cut + +use strict; +use vars qw($VERSION @ISA); +require Exporter; + +$VERSION = "1.10"; + +@ISA = qw(Exporter); # This is only so we can do version checking + +sub VEC_BITS () {0} +sub FD_COUNT () {1} +sub FIRST_FD () {2} + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + + my $vec = bless [undef,0], $type; + + $vec->add(@_) + if @_; + + $vec; +} + +sub add +{ + shift->_update('add', @_); +} + + +sub remove +{ + shift->_update('remove', @_); +} + + +sub exists +{ + my $vec = shift; + $vec->[$vec->_fileno(shift) + FIRST_FD]; +} + + +sub _fileno +{ + my($self, $f) = @_; + $f = $f->[0] if ref($f) eq 'ARRAY'; + ($f =~ /^\d+$/) ? $f : fileno($f); +} + +sub _update +{ + my $vec = shift; + my $add = shift eq 'add'; + + my $bits = $vec->[VEC_BITS]; + $bits = '' unless defined $bits; + + my $count = 0; + my $f; + foreach $f (@_) + { + my $fn = $vec->_fileno($f); + next unless defined $fn; + my $i = $fn + FIRST_FD; + if ($add) { + if (defined $vec->[$i]) { + $vec->[$i] = $f; # if array rest might be different, so we update + next; + } + $vec->[FD_COUNT]++; + vec($bits, $fn, 1) = 1; + $vec->[$i] = $f; + } else { # remove + next unless defined $vec->[$i]; + $vec->[FD_COUNT]--; + vec($bits, $fn, 1) = 0; + $vec->[$i] = undef; + } + $count++; + } + $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; + $count; +} + +sub can_read +{ + my $vec = shift; + my $timeout = shift; + my $r = $vec->[VEC_BITS]; + + defined($r) && (select($r,undef,undef,$timeout) > 0) + ? handles($vec, $r) + : (); +} + +sub can_write +{ + my $vec = shift; + my $timeout = shift; + my $w = $vec->[VEC_BITS]; + + defined($w) && (select(undef,$w,undef,$timeout) > 0) + ? handles($vec, $w) + : (); +} + +sub has_error +{ + my $vec = shift; + my $timeout = shift; + my $e = $vec->[VEC_BITS]; + + defined($e) && (select(undef,undef,$e,$timeout) > 0) + ? handles($vec, $e) + : (); +} + +sub count +{ + my $vec = shift; + $vec->[FD_COUNT]; +} + +sub bits +{ + my $vec = shift; + $vec->[VEC_BITS]; +} + +sub as_string # for debugging +{ + my $vec = shift; + my $str = ref($vec) . ": "; + my $bits = $vec->bits; + my $count = $vec->count; + $str .= defined($bits) ? unpack("b*", $bits) : "undef"; + $str .= " $count"; + my @handles = @$vec; + splice(@handles, 0, FIRST_FD); + for (@handles) { + $str .= " " . (defined($_) ? "$_" : "-"); + } + $str; +} + +sub _max +{ + my($a,$b,$c) = @_; + $a > $b + ? $a > $c + ? $a + : $c + : $b > $c + ? $b + : $c; +} + +sub select +{ + shift + if defined $_[0] && !ref($_[0]); + + my($r,$w,$e,$t) = @_; + my @result = (); + + my $rb = defined $r ? $r->[VEC_BITS] : undef; + my $wb = defined $w ? $w->[VEC_BITS] : undef; + my $eb = defined $e ? $e->[VEC_BITS] : undef; + + if(select($rb,$wb,$eb,$t) > 0) + { + my @r = (); + my @w = (); + my @e = (); + my $i = _max(defined $r ? scalar(@$r)-1 : 0, + defined $w ? scalar(@$w)-1 : 0, + defined $e ? scalar(@$e)-1 : 0); + + for( ; $i >= FIRST_FD ; $i--) + { + my $j = $i - FIRST_FD; + push(@r, $r->[$i]) + if defined $rb && defined $r->[$i] && vec($rb, $j, 1); + push(@w, $w->[$i]) + if defined $wb && defined $w->[$i] && vec($wb, $j, 1); + push(@e, $e->[$i]) + if defined $eb && defined $e->[$i] && vec($eb, $j, 1); + } + + @result = (\@r, \@w, \@e); + } + @result; +} + + +sub handles +{ + my $vec = shift; + my $bits = shift; + my @h = (); + my $i; + my $max = scalar(@$vec) - 1; + + for ($i = FIRST_FD; $i <= $max; $i++) + { + next unless defined $vec->[$i]; + push(@h, $vec->[$i]) + if !defined($bits) || vec($bits, $i - FIRST_FD, 1); + } + + @h; +} + +1; diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm new file mode 100644 index 00000000000..aadb502f193 --- /dev/null +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm @@ -0,0 +1,728 @@ +# IO::Socket.pm +# +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket; + +=head1 NAME + +IO::Socket - Object interface to socket communications + +=head1 SYNOPSIS + + use IO::Socket; + +=head1 DESCRIPTION + +C<IO::Socket> provides an object interface to creating and using sockets. It +is built upon the L<IO::Handle> interface and inherits all the methods defined +by L<IO::Handle>. + +C<IO::Socket> only defines methods for those operations which are common to all +types of socket. Operations which are specified to a socket in a particular +domain have methods defined in sub classes of C<IO::Socket> + +C<IO::Socket> will export all functions (and constants) defined by L<Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket>, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. +C<new> only looks for one key C<Domain> which tells new which domain +the socket will be in. All other arguments will be passed to the +configuration method of the package for that domain, See below. + +C<IO::Socket>s will be in autoflush mode after creation. Note that +versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04) +did not do this. So if you need backward compatibility, you should +set autoflush explicitly. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Socket> methods, which are just front ends for the +corresponding built-in functions: + + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + +Some methods take slightly different arguments to those defined in L<perlfunc> +in attempt to make the interface more flexible. These are + +=over 4 + +=item accept([PKG]) + +perform the system call C<accept> on the socket and return a new object. The +new object will be created in the same class as the listen socket, unless +C<PKG> is specified. This object can be used to communicate with the client +that was trying to connect. In a scalar context the new socket is returned, +or undef upon failure. In an array context a two-element array is returned +containing the new socket and the peer address, the list will +be empty upon failure. + +Additional methods that are provided are + +=item timeout([VAL]) + +Set or get the timeout value associated with this socket. If called without +any arguments then the current setting is returned. If called with an argument +the current setting is changed and the previous value returned. + +=item sockopt(OPT [, VAL]) + +Unified method to both set and get options in the SOL_SOCKET level. If called +with one argument then getsockopt is called, otherwise setsockopt is called. + +=item sockdomain + +Returns the numerical number for the socket domain type. For example, for +a AF_INET socket the value of &AF_INET will be returned. + +=item socktype + +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. + +=item protocol + +Returns the numerical number for the protocol being used on the socket, if +known. If the protocol is unknown, as with an AF_UNIX socket, zero +is returned. + +=back + +=cut + + +require 5.000; + +use Config; +use IO::Handle; +use Socket 1.3; +use Carp; +use strict; +use vars qw(@ISA $VERSION); +use Exporter; + +@ISA = qw(IO::Handle); + +$VERSION = "1.1603"; + +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export 'Socket', $callpkg, @_; +} + +sub new { + my($class,%arg) = @_; + my $fh = $class->SUPER::new(); + $fh->autoflush; + + ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $fh->configure(\%arg) + : $fh; +} + +my @domain2pkg = (); + +sub register_domain { + my($p,$d) = @_; + $domain2pkg[$d] = $p; +} + +sub configure { + my($fh,$arg) = @_; + my $domain = delete $arg->{Domain}; + + croak 'IO::Socket: Cannot configure a generic socket' + unless defined $domain; + + croak "IO::Socket: Unsupported socket domain" + unless defined $domain2pkg[$domain]; + + croak "IO::Socket: Cannot configure socket in domain '$domain'" + unless ref($fh) eq "IO::Socket"; + + bless($fh, $domain2pkg[$domain]); + $fh->configure($arg); +} + +sub socket { + @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; + my($fh,$domain,$type,$protocol) = @_; + + socket($fh,$domain,$type,$protocol) or + return undef; + + ${*$fh}{'io_socket_domain'} = $domain; + ${*$fh}{'io_socket_type'} = $type; + ${*$fh}{'io_socket_proto'} = $protocol; + + $fh; +} + +sub socketpair { + @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; + my($class,$domain,$type,$protocol) = @_; + my $fh1 = $class->new(); + my $fh2 = $class->new(); + + socketpair($fh1,$fh1,$domain,$type,$protocol) or + return (); + + ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; + ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol; + + ($fh1,$fh2); +} + +sub connect { + @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)'; + my $fh = shift; + my $addr = @_ == 1 ? shift : sockaddr_in(@_); + my $timeout = ${*$fh}{'io_socket_timeout'}; + local($SIG{ALRM}) = $timeout ? sub { undef $fh; } + : $SIG{ALRM} || 'DEFAULT'; + + eval { + croak 'connect: Bad address' + if(@_ == 2 && !defined $_[1]); + + if($timeout) { + defined $Config{d_alarm} && defined alarm($timeout) or + $timeout = 0; + } + + my $ok = connect($fh, $addr); + + alarm(0) + if($timeout); + + croak "connect: timeout" + unless defined $fh; + + undef $fh unless $ok; + }; + + $fh; +} + +sub bind { + @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)'; + my $fh = shift; + my $addr = @_ == 1 ? shift : sockaddr_in(@_); + + return bind($fh, $addr) ? $fh + : undef; +} + +sub listen { + @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])'; + my($fh,$queue) = @_; + $queue = 5 + unless $queue && $queue > 0; + + return listen($fh, $queue) ? $fh + : undef; +} + +sub accept { + @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])'; + my $fh = shift; + my $pkg = shift || $fh; + my $timeout = ${*$fh}{'io_socket_timeout'}; + my $new = $pkg->new(Timeout => $timeout); + my $peer = undef; + + eval { + if($timeout) { + my $fdset = ""; + vec($fdset, $fh->fileno,1) = 1; + croak "accept: timeout" + unless select($fdset,undef,undef,$timeout); + } + $peer = accept($new,$fh); + }; + + return wantarray ? defined $peer ? ($new, $peer) + : () + : defined $peer ? $new + : undef; +} + +sub sockname { + @_ == 1 or croak 'usage: $fh->sockname()'; + getsockname($_[0]); +} + +sub peername { + @_ == 1 or croak 'usage: $fh->peername()'; + my($fh) = @_; + getpeername($fh) + || ${*$fh}{'io_socket_peername'} + || undef; +} + +sub send { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])'; + my $fh = $_[0]; + my $flags = $_[2] || 0; + my $peer = $_[3] || $fh->peername; + + croak 'send: Cannot determine peer address' + unless($peer); + + my $r = defined(getpeername($fh)) + ? send($fh, $_[1], $flags) + : send($fh, $_[1], $flags, $peer); + + # remember who we send to, if it was sucessful + ${*$fh}{'io_socket_peername'} = $peer + if(@_ == 4 && defined $r); + + $r; +} + +sub recv { + @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])'; + my $sock = $_[0]; + my $len = $_[2]; + my $flags = $_[3] || 0; + + # remember who we recv'd from + ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); +} + + +sub setsockopt { + @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; + setsockopt($_[0],$_[1],$_[2],$_[3]); +} + +my $intsize = length(pack("i",0)); + +sub getsockopt { + @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)'; + my $r = getsockopt($_[0],$_[1],$_[2]); + # Just a guess + $r = unpack("i", $r) + if(defined $r && length($r) == $intsize); + $r; +} + +sub sockopt { + my $fh = shift; + @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) + : $fh->setsockopt(SOL_SOCKET,@_); +} + +sub timeout { + @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])'; + my($fh,$val) = @_; + my $r = ${*$fh}{'io_socket_timeout'} || undef; + + ${*$fh}{'io_socket_timeout'} = 0 + $val + if(@_ == 2); + + $r; +} + +sub sockdomain { + @_ == 1 or croak 'usage: $fh->sockdomain()'; + my $fh = shift; + ${*$fh}{'io_socket_domain'}; +} + +sub socktype { + @_ == 1 or croak 'usage: $fh->socktype()'; + my $fh = shift; + ${*$fh}{'io_socket_type'} +} + +sub protocol { + @_ == 1 or croak 'usage: $fh->protocol()'; + my($fh) = @_; + ${*$fh}{'io_socket_protocol'}; +} + +=head1 SUB-CLASSES + +=cut + +## +## AF_INET +## + +package IO::Socket::INET; + +use strict; +use vars qw(@ISA); +use Socket; +use Carp; +use Exporter; + +@ISA = qw(IO::Socket); + +IO::Socket::INET->register_domain( AF_INET ); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + icmp => SOCK_RAW, + ); + +=head2 IO::Socket::INET + +C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket +and some related methods. The constructor can take the following options + + PeerAddr Remote host address <hostname>[:<port>] + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name (or number) "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... + Listen Queue size for listen + Reuse Set SO_REUSEADDR before binding + Timeout Timeout value for various operations + + +If C<Listen> is defined then a listen socket is created, else if the +socket type, which is derived from the protocol, is SOCK_STREAM then +connect() is called. + +The C<PeerAddr> can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic +service name. The service name might be followed by a number in +parenthesis which is used if the service is not known by the system. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":". + +If C<Proto> is not given and you specify a symbolic C<PeerPort> port, +then the constructor will try to derive C<Proto> from the service +name. As a last resort C<Proto> "tcp" is assumed. The C<Type> +parameter will be deduced from C<Proto> if not specified. + +If the constructor is only passed a single argument, it is assumed to +be a C<PeerAddr> specification. + +Examples: + + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', + PeerPort => 'http(80)', + Proto => 'tcp'); + + $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); + + $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => 'localhost', + LocalPort => 9000, + Proto => 'tcp'); + + $sock = IO::Socket::INET->new('127.0.0.1:25'); + + +=head2 METHODS + +=over 4 + +=item sockaddr () + +Return the address part of the sockaddr structure for the socket + +=item sockport () + +Return the port number that the socket is using on the local host + +=item sockhost () + +Return the address part of the sockaddr structure for the socket in a +text form xx.xx.xx.xx + +=item peeraddr () + +Return the address part of the sockaddr structure for the socket on +the peer host + +=item peerport () + +Return the port number for the socket on the peer host. + +=item peerhost () + +Return the address part of the sockaddr structure for the socket on the +peer host in a text form xx.xx.xx.xx + +=back + +=cut + +sub new +{ + my $class = shift; + unshift(@_, "PeerAddr") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub _sock_info { + my($addr,$port,$proto) = @_; + my @proto = (); + my @serv = (); + + $port = $1 + if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); + + if(defined $proto) { + @proto = $proto =~ m,\D, ? getprotobyname($proto) + : getprotobynumber($proto); + + $proto = $proto[2] || undef; + } + + if(defined $port) { + $port =~ s,\((\d+)\)$,,; + + my $defport = $1 || undef; + my $pnum = ($port =~ m,^(\d+)$,)[0]; + + @serv= getservbyname($port, $proto[0] || "") + if($port =~ m,\D,); + + $port = $pnum || $serv[2] || $defport || undef; + + $proto = (getprotobyname($serv[3]))[2] || undef + if @serv && !$proto; + } + + return ($addr || undef, + $port || undef, + $proto || undef + ); +} + +sub _error { + my $fh = shift; + $@ = join("",ref($fh),": ",@_); + carp $@ if $^W; + close($fh) + if(defined fileno($fh)); + return undef; +} + +sub configure { + my($fh,$arg) = @_; + my($lport,$rport,$laddr,$raddr,$proto,$type); + + + ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, + $arg->{LocalPort}, + $arg->{Proto}); + + $laddr = defined $laddr ? inet_aton($laddr) + : INADDR_ANY; + + return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'") + unless(defined $laddr); + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto); + } + + if(defined $raddr) { + $raddr = inet_aton($raddr); + return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'") + unless(defined $raddr); + } + + $proto ||= (getprotobyname "tcp")[2]; + return _error($fh,'Cannot determine protocol') + unless($proto); + + my $pname = (getprotobynumber($proto))[0]; + $type = $arg->{Type} || $socket_type{$pname}; + + $fh->socket(AF_INET, $type, $proto) or + return _error($fh,"$!"); + + if ($arg->{Reuse}) { + $fh->sockopt(SO_REUSEADDR,1) or + return _error($fh); + } + + $fh->bind($lport || 0, $laddr) or + return _error($fh,"$!"); + + if(exists $arg->{Listen}) { + $fh->listen($arg->{Listen} || 5) or + return _error($fh,"$!"); + } + else { + return _error($fh,'Cannot determine remote port') + unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); + + if($type == SOCK_STREAM || defined $raddr) { + return _error($fh,'Bad peer address') + unless(defined $raddr); + + $fh->connect($rport,$raddr) or + return _error($fh,"$!"); + } + } + + $fh; +} + +sub sockaddr { + @_ == 1 or croak 'usage: $fh->sockaddr()'; + my($fh) = @_; + (sockaddr_in($fh->sockname))[1]; +} + +sub sockport { + @_ == 1 or croak 'usage: $fh->sockport()'; + my($fh) = @_; + (sockaddr_in($fh->sockname))[0]; +} + +sub sockhost { + @_ == 1 or croak 'usage: $fh->sockhost()'; + my($fh) = @_; + inet_ntoa($fh->sockaddr); +} + +sub peeraddr { + @_ == 1 or croak 'usage: $fh->peeraddr()'; + my($fh) = @_; + (sockaddr_in($fh->peername))[1]; +} + +sub peerport { + @_ == 1 or croak 'usage: $fh->peerport()'; + my($fh) = @_; + (sockaddr_in($fh->peername))[0]; +} + +sub peerhost { + @_ == 1 or croak 'usage: $fh->peerhost()'; + my($fh) = @_; + inet_ntoa($fh->peeraddr); +} + +## +## AF_UNIX +## + +package IO::Socket::UNIX; + +use strict; +use vars qw(@ISA $VERSION); +use Socket; +use Carp; +use Exporter; + +@ISA = qw(IO::Socket); + +IO::Socket::UNIX->register_domain( AF_UNIX ); + +=head2 IO::Socket::UNIX + +C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket +and some related methods. The constructor can take the following options + + Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) + Local Path to local fifo + Peer Path to peer fifo + Listen Create a listen socket + +=head2 METHODS + +=over 4 + +=item hostpath() + +Returns the pathname to the fifo at the local end + +=item peerpath() + +Returns the pathanme to the fifo at the peer end + +=back + +=cut + +sub configure { + my($fh,$arg) = @_; + my($bport,$cport); + + my $type = $arg->{Type} || SOCK_STREAM; + + $fh->socket(AF_UNIX, $type, 0) or + return undef; + + if(exists $arg->{Local}) { + my $addr = sockaddr_un($arg->{Local}); + $fh->bind($addr) or + return undef; + } + if(exists $arg->{Listen}) { + $fh->listen($arg->{Listen} || 5) or + return undef; + } + elsif(exists $arg->{Peer}) { + my $addr = sockaddr_un($arg->{Peer}); + $fh->connect($addr) or + return undef; + } + + $fh; +} + +sub hostpath { + @_ == 1 or croak 'usage: $fh->hostpath()'; + my $n = $_[0]->sockname || return undef; + (sockaddr_un($n))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $fh->peerpath()'; + my $n = $_[0]->peername || return undef; + (sockaddr_un($n))[0]; +} + +=head1 SEE ALSO + +L<Socket>, L<IO::Handle> + +=head1 AUTHOR + +Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=cut + +1; # Keep require happy diff --git a/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl b/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl new file mode 100644 index 00000000000..e96d907e10a --- /dev/null +++ b/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl @@ -0,0 +1,2 @@ +# Spider Boardman <spider@Orb.Nashua.NH.US> +$self->{LIBS} = ['']; diff --git a/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl b/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl new file mode 100644 index 00000000000..d402c179014 --- /dev/null +++ b/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl @@ -0,0 +1,3 @@ +# On DYNIX/ptx 4.0 (v4.1.3), ndbm is actually contained in the +# libc library, and must be explicitly linked against -lc when compiling. +$self->{LIBS} = ['-lc']; diff --git a/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl new file mode 100644 index 00000000000..31f9d24bcae --- /dev/null +++ b/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl @@ -0,0 +1,4 @@ +# Try to work around "bad free" messages. See note in ODBM_File.xs. +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# Sun Sep 8 12:57:52 EDT 1996 +$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ; diff --git a/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl new file mode 100644 index 00000000000..31f9d24bcae --- /dev/null +++ b/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl @@ -0,0 +1,4 @@ +# Try to work around "bad free" messages. See note in ODBM_File.xs. +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# Sun Sep 8 12:57:52 EDT 1996 +$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ; diff --git a/gnu/usr.bin/perl/ext/Opcode/Makefile.PL b/gnu/usr.bin/perl/ext/Opcode/Makefile.PL new file mode 100644 index 00000000000..7fdcdf6ac13 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Opcode/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'Opcode', + MAN3PODS => ' ', + VERSION_FROM => 'Opcode.pm', + XS_VERSION => '1.02' +); diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm new file mode 100644 index 00000000000..a35ad1b47b4 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm @@ -0,0 +1,569 @@ +package Opcode; + +require 5.002; + +use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK); + +$VERSION = "1.04"; +$XS_VERSION = "1.02"; + +use strict; +use Carp; +use Exporter (); +use DynaLoader (); +@ISA = qw(Exporter DynaLoader); + +BEGIN { + @EXPORT_OK = qw( + opset ops_to_opset + opset_to_ops opset_to_hex invert_opset + empty_opset full_opset + opdesc opcodes opmask define_optag + opmask_add verify_opset opdump + ); +} + +sub opset (;@); +sub opset_to_hex ($); +sub opdump (;$); +use subs @EXPORT_OK; + +bootstrap Opcode $XS_VERSION; + +_init_optags(); + +sub ops_to_opset { opset @_ } # alias for old name + +sub opset_to_hex ($) { + return "(invalid opset)" unless verify_opset($_[0]); + unpack("h*",$_[0]); +} + +sub opdump (;$) { + my $pat = shift; + # handy utility: perl -MOpcode=opdump -e 'opdump File' + foreach(opset_to_ops(full_opset)) { + my $op = sprintf " %12s %s\n", $_, opdesc($_); + next if defined $pat and $op !~ m/$pat/i; + print $op; + } +} + + + +sub _init_optags { + my(%all, %seen); + @all{opset_to_ops(full_opset)} = (); # keys only + + local($_); + local($/) = "\n=cut"; # skip to optags definition section + <DATA>; + $/ = "\n="; # now read in 'pod section' chunks + while(<DATA>) { + next unless m/^item\s+(:\w+)/; + my $tag = $1; + + # Split into lines, keep only indented lines + my @lines = grep { m/^\s/ } split(/\n/); + foreach (@lines) { s/--.*// } # delete comments + my @ops = map { split ' ' } @lines; # get op words + + foreach(@ops) { + warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_}; + $seen{$_} = $tag; + delete $all{$_}; + } + # opset will croak on invalid names + define_optag($tag, opset(@ops)); + } + close(DATA); + warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all; +} + + +1; + +__DATA__ + +=head1 NAME + +Opcode - Disable named opcodes when compiling perl code + +=head1 SYNOPSIS + + use Opcode; + + +=head1 DESCRIPTION + +Perl code is always compiled into an internal format before execution. + +Evaluating perl code (e.g. via "eval" or "do 'file'") causes +the code to be compiled into an internal format and then, +provided there was no error in the compilation, executed. +The internal format is based on many distinct I<opcodes>. + +By default no opmask is in effect and any code can be compiled. + +The Opcode module allow you to define an I<operator mask> to be in +effect when perl I<next> compiles any code. Attempting to compile code +which contains a masked opcode will cause the compilation to fail +with an error. The code will not be executed. + +=head1 NOTE + +The Opcode module is not usually used directly. See the ops pragma and +Safe modules for more typical uses. + +=head1 WARNING + +The authors make B<no warranty>, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B<do not use it>. + + +=head1 Operator Names and Operator Lists + +The canonical list of operator names is the contents of the array +op_name defined and initialised in file F<opcode.h> of the Perl +source distribution (and installed into the perl library). + +Each operator has both a terse name (its opname) and a more verbose or +recognisable descriptive name. The opdesc function can be used to +return a list of descriptions for a list of operators. + +Many of the functions and methods listed below take a list of +operators as parameters. Most operator lists can be made up of several +types of element. Each element can be one of + +=over 8 + +=item an operator name (opname) + +Operator names are typically small lowercase words like enterloop, +leaveloop, last, next, redo etc. Sometimes they are rather cryptic +like gv2cv, i_ncmp and ftsvtx. + +=item an operator tag name (optag) + +Operator tags can be used to refer to groups (or sets) of operators. +Tag names always being with a colon. The Opcode module defines several +optags and the user can define others using the define_optag function. + +=item a negated opname or optag + +An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir. +Negating an opname or optag means remove the corresponding ops from the +accumulated set of ops at that point. + +=item an operator set (opset) + +An I<opset> as a binary string of approximately 43 bytes which holds a +set or zero or more operators. + +The opset and opset_to_ops functions can be used to convert from +a list of operators to an opset and I<vice versa>. + +Wherever a list of operators can be given you can use one or more opsets. +See also Manipulating Opsets below. + +=back + + +=head1 Opcode Functions + +The Opcode package contains functions for manipulating operator names +tags and sets. All are available for export by the package. + +=over 8 + +=item opcodes + +In a scalar context opcodes returns the number of opcodes in this +version of perl (around 340 for perl5.002). + +In a list context it returns a list of all the operator names. +(Not yet implemented, use @names = opset_to_ops(full_opset).) + +=item opset (OP, ...) + +Returns an opset containing the listed operators. + +=item opset_to_ops (OPSET) + +Returns a list of operator names corresponding to those operators in +the set. + +=item opset_to_hex (OPSET) + +Returns a string representation of an opset. Can be handy for debugging. + +=item full_opset + +Returns an opset which includes all operators. + +=item empty_opset + +Returns an opset which contains no operators. + +=item invert_opset (OPSET) + +Returns an opset which is the inverse set of the one supplied. + +=item verify_opset (OPSET, ...) + +Returns true if the supplied opset looks like a valid opset (is the +right length etc) otherwise it returns false. If an optional second +parameter is true then verify_opset will croak on an invalid opset +instead of returning false. + +Most of the other Opcode functions call verify_opset automatically +and will croak if given an invalid opset. + +=item define_optag (OPTAG, OPSET) + +Define OPTAG as a symbolic name for OPSET. Optag names always start +with a colon C<:>. + +The optag name used must not be defined already (define_optag will +croak if it is already defined). Optag names are global to the perl +process and optag definitions cannot be altered or deleted once +defined. + +It is strongly recommended that applications using Opcode should use a +leading capital letter on their tag names since lowercase names are +reserved for use by the Opcode module. If using Opcode within a module +you should prefix your tags names with the name of your module to +ensure uniqueness and thus avoid clashes with other modules. + +=item opmask_add (OPSET) + +Adds the supplied opset to the current opmask. Note that there is +currently I<no> mechanism for unmasking ops once they have been masked. +This is intentional. + +=item opmask + +Returns an opset corresponding to the current opmask. + +=item opdesc (OP, ...) + +This takes a list of operator names and returns the corresponding list +of operator descriptions. + +=item opdump (PAT) + +Dumps to STDOUT a two column list of op names and op descriptions. +If an optional pattern is given then only lines which match the +(case insensitive) pattern will be output. + +It's designed to be used as a handy command line utility: + + perl -MOpcode=opdump -e opdump + perl -MOpcode=opdump -e 'opdump Eval' + +=back + +=head1 Manipulating Opsets + +Opsets may be manipulated using the perl bit vector operators & (and), | (or), +^ (xor) and ~ (negate/invert). + +However you should never rely on the numerical position of any opcode +within the opset. In other words both sides of a bit vector operator +should be opsets returned from Opcode functions. + +Also, since the number of opcodes in your current version of perl might +not be an exact multiple of eight, there may be unused bits in the last +byte of an upset. This should not cause any problems (Opcode functions +ignore those extra bits) but it does mean that using the ~ operator +will typically not produce the same 'physical' opset 'string' as the +invert_opset function. + + +=head1 TO DO (maybe) + + $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv + + $yes = opset_can($opset, @ops) true if $opset has all @ops set + + @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...) + +=cut + +# the =cut above is used by _init_optags() to get here quickly + +=head1 Predefined Opcode Tags + +=over 5 + +=item :base_core + + null stub scalar pushmark wantarray const defined undef + + rv2sv sassign + + rv2av aassign aelem aelemfast aslice av2arylen + + rv2hv helem hslice each values keys exists delete + + preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec + int hex oct abs pow multiply i_multiply divide i_divide + modulo i_modulo add i_add subtract i_subtract + + left_shift right_shift bit_and bit_xor bit_or negate i_negate + not complement + + lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp + slt sgt sle sge seq sne scmp + + substr vec stringify study pos length index rindex ord chr + + ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp + + match split + + list lslice splice push pop shift unshift reverse + + cond_expr flip flop andassign orassign and or xor + + warn die lineseq nextstate unstack scope enter leave + + rv2cv anoncode prototype + + entersub leavesub return method -- XXX loops via recursion? + + leaveeval -- needed for Safe to operate, is safe without entereval + +=item :base_mem + +These memory related ops are not included in :base_core because they +can easily be used to implement a resource attack (e.g., consume all +available memory). + + concat repeat join range + + anonlist anonhash + +Note that despite the existance of this optag a memory resource attack +may still be possible using only :base_core ops. + +Disabling these ops is a I<very> heavy handed way to attempt to prevent +a memory resource attack. It's probable that a specific memory limit +mechanism will be added to perl in the near future. + +=item :base_loop + +These loop ops are not included in :base_core because they can easily be +used to implement a resource attack (e.g., consume all available CPU time). + + grepstart grepwhile + mapstart mapwhile + enteriter iter + enterloop leaveloop + last next redo + goto + +=item :base_io + +These ops enable I<filehandle> (rather than filename) based input and +output. These are safe on the assumption that only pre-existing +filehandles are available for use. To create new filehandles other ops +such as open would need to be enabled. + + readline rcatline getc read + + formline enterwrite leavewrite + + print sysread syswrite send recv + + eof tell seek sysseek + + readdir telldir seekdir rewinddir + +=item :base_orig + +These are a hotchpotch of opcodes still waiting to be considered + + gvsv gv gelem + + padsv padav padhv padany + + rv2gv refgen srefgen ref + + bless -- could be used to change ownership of objects (reblessing) + + pushre regcmaybe regcomp subst substcont + + sprintf prtf -- can core dump + + crypt + + tie untie + + dbmopen dbmclose + sselect select + pipe_op sockpair + + getppid getpgrp setpgrp getpriority setpriority localtime gmtime + + entertry leavetry -- can be used to 'hide' fatal errors + +=item :base_math + +These ops are not included in :base_core because of the risk of them being +used to generate floating point exceptions (which would have to be caught +using a $SIG{FPE} handler). + + atan2 sin cos exp log sqrt + +These ops are not included in :base_core because they have an effect +beyond the scope of the compartment. + + rand srand + +=item :default + +A handy tag name for a I<reasonable> default set of ops. (The current ops +allowed are unstable while development continues. It will change.) + + :base_core :base_mem :base_loop :base_io :base_orig + +If safety matters to you (and why else would you be using the Opcode module?) +then you should not rely on the definition of this, or indeed any other, optag! + + +=item :filesys_read + + stat lstat readlink + + ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread + ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned + ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx + + fttext ftbinary + + fileno + +=item :sys_db + + ghbyname ghbyaddr ghostent shostent ehostent -- hosts + gnbyname gnbyaddr gnetent snetent enetent -- networks + gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols + gsbyname gsbyport gservent sservent eservent -- services + + gpwnam gpwuid gpwent spwent epwent getlogin -- users + ggrnam ggrgid ggrent sgrent egrent -- groups + +=item :browse + +A handy tag name for a I<reasonable> default set of ops beyond the +:default optag. Like :default (and indeed all the other optags) its +current definition is unstable while development continues. It will change. + +The :browse tag represents the next step beyond :default. It it a +superset of the :default ops and adds :filesys_read the :sys_db. +The intent being that scripts can access more (possibly sensitive) +information about your system but not be able to change it. + + :default :filesys_read :sys_db + +=item :filesys_open + + sysopen open close + umask binmode + + open_dir closedir -- other dir ops are in :base_io + +=item :filesys_write + + link unlink rename symlink truncate + + mkdir rmdir + + utime chmod chown + + fcntl -- not strictly filesys related, but possibly as dangerous? + +=item :subprocess + + backtick system + + fork + + wait waitpid + + glob -- access to Cshell via <`rm *`> + +=item :ownprocess + + exec exit kill + + time tms -- could be used for timing attacks (paranoid?) + +=item :others + +This tag holds groups of assorted specialist opcodes that don't warrant +having optags defined for them. + +SystemV Interprocess Communications: + + msgctl msgget msgrcv msgsnd + + semctl semget semop + + shmctl shmget shmread shmwrite + +=item :still_to_be_decided + + chdir + flock ioctl + + socket getpeername ssockopt + bind connect listen accept shutdown gsockopt getsockname + + sleep alarm -- changes global timer state and signal handling + sort -- assorted problems including core dumps + tied -- can be used to access object implementing a tie + pack unpack -- can be used to create/use memory pointers + + entereval -- can be used to hide code from initial compile + require dofile + + caller -- get info about calling environment and args + + reset + + dbstate -- perl -d version of nextstate(ment) opcode + +=item :dangerous + +This tag is simply a bucket for opcodes that are unlikely to be used via +a tag name but need to be tagged for completness and documentation. + + syscall dump chroot + + +=back + +=head1 SEE ALSO + +ops(3) -- perl pragma interface to Opcode module. + +Safe(3) -- Opcode and namespace limited execution compartments + +=head1 AUTHORS + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk as part of Safe version 1. + +Split out from Safe module version 1, named opcode tags and other +changes added by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. + +=cut + diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs new file mode 100644 index 00000000000..9d4b726536a --- /dev/null +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs @@ -0,0 +1,472 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */ +#define OP_MASK_BUF_SIZE (MAXO + 100) + +static HV *op_named_bits; /* cache shared for whole process */ +static SV *opset_all; /* mask with all bits set */ +static IV opset_len; /* length of opmasks in bytes */ +static int opcode_debug = 0; + +static SV *new_opset _((SV *old_opset)); +static int verify_opset _((SV *opset, int fatal)); +static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname)); +static void put_op_bitspec _((char *optag, STRLEN len, SV *opset)); +static SV *get_op_bitspec _((char *opname, STRLEN len, int fatal)); + + +/* Initialise our private op_named_bits HV. + * It is first loaded with the name and number of each perl operator. + * Then the builtin tags :none and :all are added. + * Opcode.pm loads the standard optags from __DATA__ + */ + +static void +op_names_init() +{ + int i; + STRLEN len; + char *opname; + char *bitmap; + + op_named_bits = newHV(); + for(i=0; i < maxo; ++i) { + hv_store(op_named_bits, op_name[i],strlen(op_name[i]), + Sv=newSViv(i), 0); + SvREADONLY_on(Sv); + } + + put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv))); + + opset_all = new_opset(Nullsv); + bitmap = SvPV(opset_all, len); + i = len-1; /* deal with last byte specially, see below */ + while(i-- > 0) + bitmap[i] = 0xFF; + /* Take care to set the right number of bits in the last byte */ + bitmap[len-1] = (maxo & 0x07) ? ~(0xFF << (maxo & 0x07)) : 0xFF; + put_op_bitspec(":all",0, opset_all); /* don't mortalise */ +} + + +/* Store a new tag definition. Always a mask. + * The tag must not already be defined. + * SV *mask is copied not referenced. + */ + +static void +put_op_bitspec(optag, len, mask) + char *optag; + STRLEN len; + SV *mask; +{ + SV **svp; + verify_opset(mask,1); + if (!len) + len = strlen(optag); + svp = hv_fetch(op_named_bits, optag, len, 1); + if (SvOK(*svp)) + croak("Opcode tag \"%s\" already defined", optag); + sv_setsv(*svp, mask); + SvREADONLY_on(*svp); +} + + + +/* Fetch a 'bits' entry for an opname or optag (IV/PV). + * Note that we return the actual entry for speed. + * Always sv_mortalcopy() if returing it to user code. + */ + +static SV * +get_op_bitspec(opname, len, fatal) + char *opname; + STRLEN len; + int fatal; +{ + SV **svp; + if (!len) + len = strlen(opname); + svp = hv_fetch(op_named_bits, opname, len, 0); + if (!svp || !SvOK(*svp)) { + if (!fatal) + return Nullsv; + if (*opname == ':') + croak("Unknown operator tag \"%s\"", opname); + if (*opname == '!') /* XXX here later, or elsewhere? */ + croak("Can't negate operators here (\"%s\")", opname); + if (isALPHA(*opname)) + croak("Unknown operator name \"%s\"", opname); + croak("Unknown operator prefix \"%s\"", opname); + } + return *svp; +} + + + +static SV * +new_opset(old_opset) + SV *old_opset; +{ + SV *opset; + if (old_opset) { + verify_opset(old_opset,1); + opset = newSVsv(old_opset); + } + else { + opset = newSV(opset_len); + Zero(SvPVX(opset), opset_len + 1, char); + SvCUR_set(opset, opset_len); + (void)SvPOK_only(opset); + } + /* not mortalised here */ + return opset; +} + + +static int +verify_opset(opset, fatal) + SV *opset; + int fatal; +{ + char *err = Nullch; + if (!SvOK(opset)) err = "undefined"; + else if (!SvPOK(opset)) err = "wrong type"; + else if (SvCUR(opset) != opset_len) err = "wrong size"; + if (err && fatal) { + croak("Invalid opset: %s", err); + } + return !err; +} + + +static void +set_opset_bits(bitmap, bitspec, on, opname) + char *bitmap; + SV *bitspec; + int on; + char *opname; +{ + if (SvIOK(bitspec)) { + int myopcode = SvIV(bitspec); + int offset = myopcode >> 3; + int bit = myopcode & 0x07; + if (myopcode >= maxo || myopcode < 0) + croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode); + if (opcode_debug >= 2) + warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n", + myopcode, offset, bit, opname, (on)?"on":"off"); + if (on) + bitmap[offset] |= 1 << bit; + else + bitmap[offset] &= ~(1 << bit); + } + else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { + + STRLEN len; + char *specbits = SvPV(bitspec, len); + if (opcode_debug >= 2) + warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off"); + if (on) + while(len-- > 0) bitmap[len] |= specbits[len]; + else + while(len-- > 0) bitmap[len] &= ~specbits[len]; + } + else + croak("panic: invalid bitspec for \"%s\" (type %u)", + opname, (unsigned)SvTYPE(bitspec)); +} + + +static void +opmask_add(opset) /* THE ONLY FUNCTION TO EDIT op_mask ITSELF */ + SV *opset; +{ + int i,j; + char *bitmask; + STRLEN len; + int myopcode = 0; + + verify_opset(opset,1); /* croaks on bad opset */ + + if (!op_mask) /* caller must ensure op_mask exists */ + croak("Can't add to uninitialised op_mask"); + + /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */ + + bitmask = SvPV(opset, len); + for (i=0; i < opset_len; i++) { + U16 bits = bitmask[i]; + if (!bits) { /* optimise for sparse masks */ + myopcode += 8; + continue; + } + for (j=0; j < 8 && myopcode < maxo; ) + op_mask[myopcode++] |= bits & (1 << j++); + } +} + +static void +opmask_addlocal(opset, op_mask_buf) /* Localise op_mask then opmask_add() */ + SV *opset; + char *op_mask_buf; +{ + char *orig_op_mask = op_mask; + SAVEPPTR(op_mask); + if (opcode_debug >= 2) + SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored"); + op_mask = &op_mask_buf[0]; + if (orig_op_mask) + Copy(orig_op_mask, op_mask, maxo, char); + else + Zero(op_mask, maxo, char); + opmask_add(opset); +} + + + +MODULE = Opcode PACKAGE = Opcode + +PROTOTYPES: ENABLE + +BOOT: + assert(maxo < OP_MASK_BUF_SIZE); + opset_len = (maxo + 7) / 8; + if (opcode_debug >= 1) + warn("opset_len %ld\n", (long)opset_len); + op_names_init(); + + +void +_safe_call_sv(package, mask, codesv) + char * package + SV * mask + SV * codesv + PPCODE: + char op_mask_buf[OP_MASK_BUF_SIZE]; + GV *gv; + + ENTER; + + opmask_addlocal(mask, op_mask_buf); + + save_aptr(&endav); + endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ + + save_hptr(&defstash); /* save current default stack */ + /* the assignment to global defstash changes our sense of 'main' */ + defstash = gv_stashpv(package, GV_ADDWARN); /* should exist already */ + + /* defstash must itself contain a main:: so we'll add that now */ + /* take care with the ref counts (was cause of long standing bug) */ + /* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */ + gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV); + sv_free((SV*)GvHV(gv)); + GvHV(gv) = (HV*)SvREFCNT_inc(defstash); + + PUSHMARK(sp); + perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ + SPAGAIN; /* for the PUTBACK added by xsubpp */ + LEAVE; + + +int +verify_opset(opset, fatal = 0) + SV *opset + int fatal + + +void +invert_opset(opset) + SV *opset + CODE: + { + char *bitmap; + STRLEN len = opset_len; + opset = new_opset(opset); /* verify and clone opset */ + bitmap = SvPVX(opset); + while(len-- > 0) + bitmap[len] = ~bitmap[len]; + /* take care of extra bits beyond maxo in last byte */ + if (maxo & 07) + bitmap[opset_len-1] &= ~(0xFF << (maxo & 0x07)); + } + ST(0) = opset; + + +void +opset_to_ops(opset, desc = 0) + SV *opset + int desc + PPCODE: + { + STRLEN len; + int i, j, myopcode; + char *bitmap = SvPV(opset, len); + char **names = (desc) ? op_desc : op_name; + verify_opset(opset,1); + for (myopcode=0, i=0; i < opset_len; i++) { + U16 bits = bitmap[i]; + for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) { + if ( bits & (1 << j) ) + XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0))); + } + } + } + + +void +opset(...) + CODE: + int i, j; + SV *bitspec, *opset; + char *bitmap; + STRLEN len, on; + opset = new_opset(Nullsv); + bitmap = SvPVX(opset); + for (i = 0; i < items; i++) { + char *opname; + on = 1; + if (verify_opset(ST(i),0)) { + opname = "(opset)"; + bitspec = ST(i); + } + else { + opname = SvPV(ST(i), len); + if (*opname == '!') { on=0; ++opname;--len; } + bitspec = get_op_bitspec(opname, len, 1); + } + set_opset_bits(bitmap, bitspec, on, opname); + } + ST(0) = opset; + + +#define PERMITING (ix == 0 || ix == 1) +#define ONLY_THESE (ix == 0 || ix == 2) + +void +permit_only(safe, ...) + SV *safe + ALIAS: + permit = 1 + deny_only = 2 + deny = 3 + CODE: + int i, on; + SV *bitspec, *mask; + char *bitmap, *opname; + STRLEN len; + + if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV) + croak("Not a Safe object"); + mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1); + if (ONLY_THESE) /* *_only = new mask, else edit current */ + sv_setsv(mask, new_opset(PERMITING ? opset_all : Nullsv)); + else verify_opset(mask,1); /* croaks */ + bitmap = SvPVX(mask); + for (i = 1; i < items; i++) { + on = PERMITING ? 0 : 1; /* deny = mask bit on */ + if (verify_opset(ST(i),0)) { /* it's a valid mask */ + opname = "(opset)"; + bitspec = ST(i); + } + else { /* it's an opname/optag */ + opname = SvPV(ST(i), len); + /* invert if op has ! prefix (only one allowed) */ + if (*opname == '!') { on = !on; ++opname; --len; } + bitspec = get_op_bitspec(opname, len, 1); /* croaks */ + } + set_opset_bits(bitmap, bitspec, on, opname); + } + ST(0) = &sv_yes; + + + +void +opdesc(...) + PPCODE: + int i, myopcode; + STRLEN len; + SV **args; + /* copy args to a scratch area since we may push output values onto */ + /* the stack faster than we read values off it if masks are used. */ + args = (SV**)SvPVX(sv_2mortal(newSVpv((char*)&ST(0), items*sizeof(SV*)))); + for (i = 0; i < items; i++) { + char *opname = SvPV(args[i], len); + SV *bitspec = get_op_bitspec(opname, len, 1); + if (SvIOK(bitspec)) { + myopcode = SvIV(bitspec); + if (myopcode < 0 || myopcode >= maxo) + croak("panic: opcode %d (%s) out of range",myopcode,opname); + XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); + } + else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { + int b, j; + char *bitmap = SvPV(bitspec,na); + myopcode = 0; + for (b=0; b < opset_len; b++) { + U16 bits = bitmap[b]; + for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) + if (bits & (1 << j)) + XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); + } + } + else + croak("panic: invalid bitspec for \"%s\" (type %u)", + opname, (unsigned)SvTYPE(bitspec)); + } + + +void +define_optag(optagsv, mask) + SV *optagsv + SV *mask + CODE: + STRLEN len; + char *optag = SvPV(optagsv, len); + put_op_bitspec(optag, len, mask); /* croaks */ + ST(0) = &sv_yes; + + +void +empty_opset() + CODE: + ST(0) = sv_2mortal(new_opset(Nullsv)); + +void +full_opset() + CODE: + ST(0) = sv_2mortal(new_opset(opset_all)); + +void +opmask_add(opset) + SV *opset + PREINIT: + if (!op_mask) + Newz(0, op_mask, maxo, char); + +void +opcodes() + PPCODE: + if (GIMME == G_ARRAY) { + croak("opcodes in list context not yet implemented"); /* XXX */ + } + else { + XPUSHs(sv_2mortal(newSViv(maxo))); + } + +void +opmask() + CODE: + ST(0) = sv_2mortal(new_opset(Nullsv)); + if (op_mask) { + char *bitmap = SvPVX(ST(0)); + int myopcode; + for(myopcode=0; myopcode < maxo; ++myopcode) { + if (op_mask[myopcode]) + bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07); + } + } + diff --git a/gnu/usr.bin/perl/ext/Opcode/Safe.pm b/gnu/usr.bin/perl/ext/Opcode/Safe.pm new file mode 100644 index 00000000000..c9d741647ec --- /dev/null +++ b/gnu/usr.bin/perl/ext/Opcode/Safe.pm @@ -0,0 +1,555 @@ +package Safe; + +use 5.003_11; +use strict; +use vars qw($VERSION); + +$VERSION = "2.06"; + +use Carp; + +use Opcode 1.01, qw( + opset opset_to_ops opmask_add + empty_opset full_opset invert_opset verify_opset + opdesc opcodes opmask define_optag opset_to_hex +); + +*ops_to_opset = \&opset; # Temporary alias for old Penguins + + +my $default_root = 0; +my $default_share = ['*_']; #, '*main::']; + +sub new { + my($class, $root, $mask) = @_; + my $obj = {}; + bless $obj, $class; + + if (defined($root)) { + croak "Can't use \"$root\" as root name" + if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/; + $obj->{Root} = $root; + $obj->{Erase} = 0; + } + else { + $obj->{Root} = "Safe::Root".$default_root++; + $obj->{Erase} = 1; + } + + # use permit/deny methods instead till interface issues resolved + # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...; + croak "Mask parameter to new no longer supported" if defined $mask; + $obj->permit_only(':default'); + + # We must share $_ and @_ with the compartment or else ops such + # as split, length and so on won't default to $_ properly, nor + # will passing argument to subroutines work (via @_). In fact, + # for reasons I don't completely understand, we need to share + # the whole glob *_ rather than $_ and @_ separately, otherwise + # @_ in non default packages within the compartment don't work. + $obj->share_from('main', $default_share); + return $obj; +} + +sub DESTROY { + my $obj = shift; + $obj->erase if $obj->{Erase}; +} + +sub erase { + my $obj= shift; + my $pkg = $obj->root(); + my ($stem, $leaf); + + no strict 'refs'; + $pkg = "main::$pkg\::"; # expand to full symbol table name + ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + + # The 'my $foo' is needed! Without it you get an + # 'Attempt to free unreferenced scalar' warning! + my $stem_symtab = *{$stem}{HASH}; + + #warn "erase($pkg) stem=$stem, leaf=$leaf"; + #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; + # ", join(', ', %$stem_symtab),"\n"; + + delete $stem_symtab->{$leaf}; + +# my $leaf_glob = $stem_symtab->{$leaf}; +# my $leaf_symtab = *{$leaf_glob}{HASH}; +# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; +# %$leaf_symtab = (); + #delete $leaf_symtab->{'__ANON__'}; + #delete $leaf_symtab->{'foo'}; + #delete $leaf_symtab->{'main::'}; +# my $foo = undef ${"$stem\::"}{"$leaf\::"}; + + $obj->share_from('main', $default_share); + 1; +} + + +sub reinit { + my $obj= shift; + $obj->erase; + $obj->share_redo; +} + +sub root { + my $obj = shift; + croak("Safe root method now read-only") if @_; + return $obj->{Root}; +} + + +sub mask { + my $obj = shift; + return $obj->{Mask} unless @_; + $obj->deny_only(@_); +} + +# v1 compatibility methods +sub trap { shift->deny(@_) } +sub untrap { shift->permit(@_) } + +sub deny { + my $obj = shift; + $obj->{Mask} |= opset(@_); +} +sub deny_only { + my $obj = shift; + $obj->{Mask} = opset(@_); +} + +sub permit { + my $obj = shift; + # XXX needs testing + $obj->{Mask} &= invert_opset opset(@_); +} +sub permit_only { + my $obj = shift; + $obj->{Mask} = invert_opset opset(@_); +} + + +sub dump_mask { + my $obj = shift; + print opset_to_hex($obj->{Mask}),"\n"; +} + + + +sub share { + my($obj, @vars) = @_; + $obj->share_from(scalar(caller), \@vars); +} + +sub share_from { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $no_record = shift || 0; + my $root = $obj->root(); + croak("vars not an array ref") unless ref $vars eq 'ARRAY'; + no strict 'refs'; + # Check that 'from' package actually exists + croak("Package \"$pkg\" does not exist") + unless keys %{"$pkg\::"}; + my $arg; + foreach $arg (@$vars) { + # catch some $safe->share($var) errors: + croak("'$arg' not a valid symbol table name") + unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/ + or $arg =~ /^\$\W$/; + my ($var, $type); + $type = $1 if ($var = $arg) =~ s/^(\W)//; + # warn "share_from $pkg $type $var"; + *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"} + : ($type eq '&') ? \&{$pkg."::$var"} + : ($type eq '$') ? \${$pkg."::$var"} + : ($type eq '@') ? \@{$pkg."::$var"} + : ($type eq '%') ? \%{$pkg."::$var"} + : ($type eq '*') ? *{$pkg."::$var"} + : croak(qq(Can't share "$type$var" of unknown type)); + } + $obj->share_record($pkg, $vars) unless $no_record or !$vars; +} + +sub share_record { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + # Record shares using keys of $obj->{Shares}. See reinit. + @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; +} +sub share_redo { + my $obj = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + my($var, $pkg); + while(($var, $pkg) = each %$shares) { + # warn "share_redo $pkg\:: $var"; + $obj->share_from($pkg, [ $var ], 1); + } +} +sub share_forget { + delete shift->{Shares}; +} + +sub varglob { + my ($obj, $var) = @_; + no strict 'refs'; + return *{$obj->root()."::$var"}; +} + + +sub reval { + my ($obj, $expr, $strict) = @_; + my $root = $obj->{Root}; + + # Create anon sub ref in root of compartment. + # Uses a closure (on $expr) to pass in the code to be executed. + # (eval on one line to keep line numbers as expected by caller) + my $evalcode = sprintf('package %s; sub { eval $expr; }', $root); + my $evalsub; + + if ($strict) { use strict; $evalsub = eval $evalcode; } + else { no strict; $evalsub = eval $evalcode; } + + return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); +} + +sub rdo { + my ($obj, $file) = @_; + my $root = $obj->{Root}; + + my $evalsub = eval + sprintf('package %s; sub { do $file }', $root); + return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); +} + + +1; + +__DATA__ + +=head1 NAME + +Safe - Compile and execute code in restricted compartments + +=head1 SYNOPSIS + + use Safe; + + $compartment = new Safe; + + $compartment->permit(qw(time sort :browse)); + + $result = $compartment->reval($unsafe_code); + +=head1 DESCRIPTION + +The Safe extension module allows the creation of compartments +in which perl code can be evaluated. Each compartment has + +=over 8 + +=item a new namespace + +The "root" of the namespace (i.e. "main::") is changed to a +different package and code evaluated in the compartment cannot +refer to variables outside this namespace, even with run-time +glob lookups and other tricks. + +Code which is compiled outside the compartment can choose to place +variables into (or I<share> variables with) the compartment's namespace +and only that data will be visible to code evaluated in the +compartment. + +By default, the only variables shared with compartments are the +"underscore" variables $_ and @_ (and, technically, the less frequently +used %_, the _ filehandle and so on). This is because otherwise perl +operators which default to $_ will not work and neither will the +assignment of arguments to @_ on subroutine entry. + +=item an operator mask + +Each compartment has an associated "operator mask". Recall that +perl code is compiled into an internal format before execution. +Evaluating perl code (e.g. via "eval" or "do 'file'") causes +the code to be compiled into an internal format and then, +provided there was no error in the compilation, executed. +Code evaulated in a compartment compiles subject to the +compartment's operator mask. Attempting to evaulate code in a +compartment which contains a masked operator will cause the +compilation to fail with an error. The code will not be executed. + +The default operator mask for a newly created compartment is +the ':default' optag. + +It is important that you read the Opcode(3) module documentation +for more information, especially for detailed definitions of opnames, +optags and opsets. + +Since it is only at the compilation stage that the operator mask +applies, controlled access to potentially unsafe operations can +be achieved by having a handle to a wrapper subroutine (written +outside the compartment) placed into the compartment. For example, + + $cpt = new Safe; + sub wrapper { + # vet arguments and perform potentially unsafe operations + } + $cpt->share('&wrapper'); + +=back + + +=head1 WARNING + +The authors make B<no warranty>, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B<do not use it>. + + +=head2 RECENT CHANGES + +The interface to the Safe module has changed quite dramatically since +version 1 (as supplied with Perl5.002). Study these pages carefully if +you have code written to use Safe version 1 because you will need to +makes changes. + + +=head2 Methods in class Safe + +To create a new compartment, use + + $cpt = new Safe; + +Optional argument is (NAMESPACE), where NAMESPACE is the root namespace +to use for the compartment (defaults to "Safe::Root0", incremented for +each new compartment). + +Note that version 1.00 of the Safe module supported a second optional +parameter, MASK. That functionality has been withdrawn pending deeper +consideration. Use the permit and deny methods described below. + +The following methods can then be used on the compartment +object returned by the above constructor. The object argument +is implicit in each case. + + +=over 8 + +=item permit (OP, ...) + +Permit the listed operators to be used when compiling code in the +compartment (in I<addition> to any operators already permitted). + +=item permit_only (OP, ...) + +Permit I<only> the listed operators to be used when compiling code in +the compartment (I<no> other operators are permitted). + +=item deny (OP, ...) + +Deny the listed operators from being used when compiling code in the +compartment (other operators may still be permitted). + +=item deny_only (OP, ...) + +Deny I<only> the listed operators from being used when compiling code +in the compartment (I<all> other operators will be permitted). + +=item trap (OP, ...) + +=item untrap (OP, ...) + +The trap and untrap methods are synonyms for deny and permit +respectfully. + +=item share (NAME, ...) + +This shares the variable(s) in the argument list with the compartment. +This is almost identical to exporting variables using the L<Exporter(3)> +module. + +Each NAME must be the B<name> of a variable, typically with the leading +type identifier included. A bareword is treated as a function name. + +Examples of legal names are '$foo' for a scalar, '@foo' for an +array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo' +for a glob (i.e. all symbol table entries associated with "foo", +including scalar, array, hash, sub and filehandle). + +Each NAME is assumed to be in the calling package. See share_from +for an alternative method (which share uses). + +=item share_from (PACKAGE, ARRAYREF) + +This method is similar to share() but allows you to explicitly name the +package that symbols should be shared from. The symbol names (including +type characters) are supplied as an array reference. + + $safe->share_from('main', [ '$foo', '%bar', 'func' ]); + + +=item varglob (VARNAME) + +This returns a glob reference for the symbol table entry of VARNAME in +the package of the compartment. VARNAME must be the B<name> of a +variable without any leading type marker. For example, + + $cpt = new Safe 'Root'; + $Root::foo = "Hello world"; + # Equivalent version which doesn't need to know $cpt's package name: + ${$cpt->varglob('foo')} = "Hello world"; + + +=item reval (STRING) + +This evaluates STRING as perl code inside the compartment. + +The code can only see the compartment's namespace (as returned by the +B<root> method). The compartment's root package appears to be the +C<main::> package to the code inside the compartment. + +Any attempt by the code in STRING to use an operator which is not permitted +by the compartment will cause an error (at run-time of the main program +but at compile-time for the code in STRING). The error is of the form +"%s trapped by operation mask operation...". + +If an operation is trapped in this way, then the code in STRING will +not be executed. If such a trapped operation occurs or any other +compile-time or return error, then $@ is set to the error message, just +as with an eval(). + +If there is no error, then the method returns the value of the last +expression evaluated, or a return statement may be used, just as with +subroutines and B<eval()>. The context (list or scalar) is determined +by the caller as usual. + +This behaviour differs from the beta distribution of the Safe extension +where earlier versions of perl made it hard to mimic the return +behaviour of the eval() command and the context was always scalar. + +Some points to note: + +If the entereval op is permitted then the code can use eval "..." to +'hide' code which might use denied ops. This is not a major problem +since when the code tries to execute the eval it will fail because the +opmask is still in effect. However this technique would allow clever, +and possibly harmful, code to 'probe' the boundaries of what is +possible. + +Any string eval which is executed by code executing in a compartment, +or by code called from code executing in a compartment, will be eval'd +in the namespace of the compartment. This is potentially a serious +problem. + +Consider a function foo() in package pkg compiled outside a compartment +but shared with it. Assume the compartment has a root package called +'Root'. If foo() contains an eval statement like eval '$foo = 1' then, +normally, $pkg::foo will be set to 1. If foo() is called from the +compartment (by whatever means) then instead of setting $pkg::foo, the +eval will actually set $Root::pkg::foo. + +This can easily be demonstrated by using a module, such as the Socket +module, which uses eval "..." as part of an AUTOLOAD function. You can +'use' the module outside the compartment and share an (autoloaded) +function with the compartment. If an autoload is triggered by code in +the compartment, or by any code anywhere that is called by any means +from the compartment, then the eval in the Socket module's AUTOLOAD +function happens in the namespace of the compartment. Any variables +created or used by the eval'd code are now under the control of +the code in the compartment. + +A similar effect applies to I<all> runtime symbol lookups in code +called from a compartment but not compiled within it. + + + +=item rdo (FILENAME) + +This evaluates the contents of file FILENAME inside the compartment. +See above documentation on the B<reval> method for further details. + +=item root (NAMESPACE) + +This method returns the name of the package that is the root of the +compartment's namespace. + +Note that this behaviour differs from version 1.00 of the Safe module +where the root module could be used to change the namespace. That +functionality has been withdrawn pending deeper consideration. + +=item mask (MASK) + +This is a get-or-set method for the compartment's operator mask. + +With no MASK argument present, it returns the current operator mask of +the compartment. + +With the MASK argument present, it sets the operator mask for the +compartment (equivalent to calling the deny_only method). + +=back + + +=head2 Some Safety Issues + +This section is currently just an outline of some of the things code in +a compartment might do (intentionally or unintentionally) which can +have an effect outside the compartment. + +=over 8 + +=item Memory + +Consuming all (or nearly all) available memory. + +=item CPU + +Causing infinite loops etc. + +=item Snooping + +Copying private information out of your system. Even something as +simple as your user name is of value to others. Much useful information +could be gleaned from your environment variables for example. + +=item Signals + +Causing signals (especially SIGFPE and SIGALARM) to affect your process. + +Setting up a signal handler will need to be carefully considered +and controlled. What mask is in effect when a signal handler +gets called? If a user can get an imported function to get an +exception and call the user's signal handler, does that user's +restricted mask get re-instated before the handler is called? +Does an imported handler get called with its original mask or +the user's one? + +=item State Changes + +Ops such as chdir obviously effect the process as a whole and not just +the code in the compartment. Ops such as rand and srand have a similar +but more subtle effect. + +=back + +=head2 AUTHOR + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk. + +Reworked to use the Opcode module and other changes added by Tim Bunce +E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. + +=cut + diff --git a/gnu/usr.bin/perl/ext/Opcode/ops.pm b/gnu/usr.bin/perl/ext/Opcode/ops.pm new file mode 100644 index 00000000000..b9ea36cef39 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Opcode/ops.pm @@ -0,0 +1,45 @@ +package ops; + +use Opcode qw(opmask_add opset invert_opset); + +sub import { + shift; + # Not that unimport is the prefered form since import's don't + # accumulate well owing to the 'only ever add opmask' rule. + # E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected. + opmask_add(invert_opset opset(@_)) if @_; +} + +sub unimport { + shift; + opmask_add(opset(@_)) if @_; +} + +1; + +__END__ + +=head1 NAME + +ops - Perl pragma to restrict unsafe operations when compiling + +=head1 SYNOPSIS + + perl -Mops=:default ... # only allow reasonably safe operations + + perl -M-ops=system ... # disable the 'system' opcode + +=head1 DESCRIPTION + +Since the ops pragma currently has an irreversable global effect, it is +only of significant practical use with the C<-M> option on the command line. + +See the L<Opcode> module for information about opcodes, optags, opmasks +and important information about safety. + +=head1 SEE ALSO + +Opcode(3), Safe(3), perlrun(3) + +=cut + diff --git a/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl b/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl new file mode 100644 index 00000000000..d90778398b2 --- /dev/null +++ b/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl @@ -0,0 +1,5 @@ +# NeXT *does* have setpgid when we use the -posix flag, but +# doesn't when we don't. The main perl sources are compiled +# without -posix, so the hints/next_3.sh hint file tells Configure +# that d_setpgid=undef. +$self->{CCFLAGS} = $Config{ccflags} . ' -posix -DHAS_SETPGID' ; diff --git a/gnu/usr.bin/perl/hints/amigaos.sh b/gnu/usr.bin/perl/hints/amigaos.sh new file mode 100644 index 00000000000..e7686436913 --- /dev/null +++ b/gnu/usr.bin/perl/hints/amigaos.sh @@ -0,0 +1,55 @@ +# hints/amigaos.sh +# +# talk to pueschel@imsdd.meb.uni-bonn.de if you want to change this file. +# +# misc stuff +archname='m68k-amigaos' +cc='gcc' +firstmakefile='GNUmakefile' +usenm='true' + +usemymalloc='n' +usevfork='true' +useperlio='true' +d_eofnblk='define' +d_fork='undef' +d_vfork='define' +groupstype='int' + +# libs + +libpth="$prefix/lib /local/lib" +glibpth="$libpth" +xlibpth="$libpth" + +libswanted='gdbm m dld' +so=' ' + +# compiler & linker flags + +ccflags='-DAMIGAOS -mstackextend' +ldflags='' +optimize='-O2 -fomit-frame-pointer' +dlext='o' +cccdlflags='none' +ccdlflags='none' +lddlflags='-oformat a.out-amiga -r' + +# uncomment the following settings if you are compiling for an 68020+ system +# and want a residentable executable instead of dynamic loading + +# usedl='n' +# ccflags='-DAMIGAOS -mstackextend -m68020 -resident32' +# ldflags='-m68020 -resident32' + +# Avoid telldir prototype conflict in pp_sys.c (AmigaOS uses const DIR *) +# Configure should test for this. Volunteers? +pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"' + +# AmigaOS always reports only two links to directories, even if they +# contain subdirectories. Consequently, we use this variable to stop +# File::Find using the link count to determine whether there are +# subdirectories to be searched. This will generate a harmless message: +# Hmm...You had some extra variables I don't know about...I'll try to keep 'em. +# Propagating recommended variable dont_use_nlink +dont_use_nlink='define' diff --git a/gnu/usr.bin/perl/hints/aux_3.sh b/gnu/usr.bin/perl/hints/aux_3.sh new file mode 100644 index 00000000000..aa3150afbe7 --- /dev/null +++ b/gnu/usr.bin/perl/hints/aux_3.sh @@ -0,0 +1,22 @@ +# hints/aux_3.sh +# +# Improved by Jake Hamby <jehamby@lightside.com> to support both Apple CC +# and GNU CC. Tested on A/UX 3.1.1 with GCC 2.6.3. +# Now notifies of problem with version of dbm shipped with A/UX +# Last modified +# Sun Jan 5 11:16:41 WET 1997 + +case "$cc" in +*gcc*) optimize='-O2' + ccflags="$ccflags -D_POSIX_SOURCE" + echo "Setting hints for GNU CC." + ;; +*) optimize='-O' + ccflags="$ccflags -B/usr/lib/big/ -DPARAM_NEEDS_TYPES -D_POSIX_SOURCE" + POSIX_cflags='ccflags="$ccflags -ZP -Du_long=U32"' + echo "Setting hints for Apple's CC. If you plan to use" + echo "GNU CC, please rerun this Configure script as:" + echo "./Configure -Dcc=gcc" + ;; +esac +test -r ./broken-db.msg && . ./broken-db.msg diff --git a/gnu/usr.bin/perl/hints/broken-db.msg b/gnu/usr.bin/perl/hints/broken-db.msg new file mode 100644 index 00000000000..92ba0776bfc --- /dev/null +++ b/gnu/usr.bin/perl/hints/broken-db.msg @@ -0,0 +1,14 @@ +# Several OSs come with an old version of the DB library which fails +# on a few of the db-recno.t tests. This file is sourced by the hints +# files for those OSs. + +cat <<EOF >&4 + +Unless you've upgraded your DB library manually you will see failures in +db-recno tests 51, 53 and 55. The behavior these tests are checking is +broken in the DB library which is included with the OS. You can ignore +the errors if you're never going to use the broken functionality (recno +databases with a modified bval), otherwise you'll have to upgrade your +DB library or OS. + +EOF diff --git a/gnu/usr.bin/perl/hints/cygwin32.sh b/gnu/usr.bin/perl/hints/cygwin32.sh new file mode 100644 index 00000000000..5853499954a --- /dev/null +++ b/gnu/usr.bin/perl/hints/cygwin32.sh @@ -0,0 +1,50 @@ +#! /bin/sh +# cygwin32.sh - hintsfile for building perl on Windows NT using the +# Cygnus Win32 Development Kit. +# See "http://www.cygnus.com/misc/gnu-win32/" to learn about the kit. +# +path_sep=\; +exe_ext='.exe' +firstmakefile='GNUmakefile' +if test -f $sh.exe; then sh=$sh.exe; fi +startsh="#!$sh" +cc='gcc2' +ld='ld2' +usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include' +libpth='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib /gnuwin32/H-i386-cygwin32/lib' +libs='-lcygwin -lm -lc -lkernel32' +# dynamic lib stuff +so='dll' +#i_dlfcn='define' +dlsrc='dl_cygwin32.xs' +usedl='y' +# flag to include the perl.exe export variable translation file cw32imp.h +# when building extension libs +cccdlflags='-DCYGWIN32 -DDLLIMPORT ' +# flag that signals gcc2 to build exportable perl +ccdlflags='-buildperl ' +lddlflags='-L../.. -L/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib -lperlexp -lcygwin' +d_voidsig='undef' +extensions='Fcntl IO Opcode SDBM_File' +lns='cp' +signal_t='int' +useposix='false' +rd_nodata='0' +eagain='EAGAIN' +archname='cygwin32' +# + +installbin='/usr/local/bin' +installman1dir='' +installman3dir='' +installprivlib='/usr/local/lib/perl5' +installscript='/usr/local/bin' + +installsitelib='/usr/local/lib/perl5/site_perl' +libc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib/libc.a' + +perlpath='/usr/local/bin/perl' + +sitelib='/usr/local/lib/perl5/site_perl' +sitelibexp='/usr/local/lib/perl5/site_perl' +usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include' diff --git a/gnu/usr.bin/perl/hints/dcosx.sh b/gnu/usr.bin/perl/hints/dcosx.sh new file mode 100644 index 00000000000..c1b0d0ac420 --- /dev/null +++ b/gnu/usr.bin/perl/hints/dcosx.sh @@ -0,0 +1,188 @@ +# hints/dcosx.sh +# Last modified: Thu Jan 16 11:38:12 EST 1996 +# Stephen Zander <stephen.zander@interlock.mckesson.com> +# hints for DC/OSx (Pyramid) & SINIX (Seimens: dc/osx rebadged) +# Based on the hints/solaris_2.sh file + +# See man vfork. +usevfork=false + +d_suidsafe=define + +# Avoid all libraries in /usr/ucblib. +set `echo $glibpth | sed -e 's@/usr/ucblib@@'` +glibpth="$*" + +# Remove bad libraries. +# -lucb contains incompatible routines. +set `echo " $libswanted " | sed -e 's@ ucb @ @'` +libswanted="$*" + +# Here's another draft of the perl5/solaris/gcc sanity-checker. + +case $PATH in +*/usr/ucb*:/usr/bin:*|*/usr/ucb*:/usr/bin) cat <<END >&2 + +NOTE: /usr/ucb/cc does not function properly. +Remove /usr/ucb from your PATH. + +END +;; +esac + + +# Check that /dev/fd is mounted. If it is not mounted, let the +# user know that suid scripts may not work. +/usr/bin/df /dev/fd 2>&1 > /dev/null +case $? in +0) ;; +*) + cat <<END >&4 + +NOTE: Your system does not have /dev/fd mounted. If you want to +be able to use set-uid scripts you must ask your system administrator +to mount /dev/fd. + +END + ;; +esac + + +# See if libucb can be found in /usr/lib. If it is, warn the user +# that this may cause problems while building Perl extensions. +/usr/bin/ls /usr/lib/libucb* >/dev/null 2>&1 +case $? in +0) + cat <<END >&4 + +NOTE: libucb has been found in /usr/lib. libucb should reside in +/usr/ucblib. You may have trouble while building Perl extensions. + +END +;; +esac + + +# See if make(1) is GNU make(1). +# If it is, make sure the setgid bit is not set. +make -v > make.vers 2>&1 +if grep GNU make.vers > /dev/null 2>&1; then + tmp=`/usr/bin/ksh -c "whence make"` + case "`/usr/bin/ls -l $tmp`" in + ??????s*) + cat <<END >&2 + +NOTE: Your PATH points to GNU make, and your GNU make has the set-group-id +bit set. You must either rearrange your PATH to put /usr/ccs/bin before the +GNU utilities or you must ask your system administrator to disable the +set-group-id bit on GNU make. + +END + ;; + esac +fi +rm -f make.vers + +# If the C compiler is gcc: +# - check the fixed-includes +# - check as(1) and ld(1), they should not be GNU +# If the C compiler is not gcc: +# - check as(1) and ld(1), they should not be GNU +# - increase the optimizing level to prevent object size warnings +# +# Watch out in case they have not set $cc. +case "`${cc:-cc} -v 2>&1`" in +*gcc*) + # + # Using gcc. + # + #echo Using gcc + + # Get gcc to share its secrets. + echo 'main() { return 0; }' > try.c + verbose=`${cc:-cc} -v -o try try.c 2>&1` + rm -f try try.c + tmp=`echo "$verbose" | grep '^Reading' | + awk '{print $NF}' | sed 's/specs$/include/'` + + # Determine if the fixed-includes look like they'll work. + # Doesn't work anymore for gcc-2.7.2. + + # See if as(1) is GNU as(1). GNU as(1) won't work for this job. + case $verbose in + */usr/ccs/bin/as*) ;; + *) + cat <<END >&2 + +NOTE: You are using GNU as(1). GNU as(1) will not build Perl. +You must arrange to use /usr/ccs/bin/as, perhaps by setting +GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command. + +END + ;; + esac + + # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job. + case $verbose in + */usr/ccs/bin/ld*) ;; + *) + cat <<END >&2 + +NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl. +You must arrange to use /usr/ccs/bin/ld, perhaps by setting +GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command. + +END + ;; + esac + + ;; #using gcc +*) + optimize='-O -K Olimit:3064' + # + # Not using gcc. + # + #echo Not using gcc + + # See if as(1) is GNU as(1). GNU as(1) won't work for this job. + case `as --version < /dev/null 2>&1` in + *GNU*) + cat <<END >&2 + +NOTE: You are using GNU as(1). GNU as(1) will not build Perl. +You must arrange to use /usr/ccs/bin, perhaps by adding it to the +beginning of your PATH. + +END + ;; + esac + + # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job. + case `ld --version < /dev/null 2>&1` in + *GNU*) + cat <<END >&2 + +NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl. +You must arrange to use /usr/ccs/bin, perhaps by adding it to the +beginning of your PATH + +END + ;; + esac + + ;; #not using gcc +esac + +# as --version or ld --version might dump core. +rm -f core + +# DC/OSx hides certain functions in a libc that looks dynamic but isn't +# because of this we reinclude -lc when building dynamic extenstions +libc='/usr/ccs/lib/libc.so' +lddlflags='-G -lc' + +# DC/OSx gets overenthusiastic with symbol removal when building dynamically +ccdlflags='-Blargedynsym' + +# System malloc is safer when using third part libs +usemymalloc='n' diff --git a/gnu/usr.bin/perl/hints/irix_6_0.sh b/gnu/usr.bin/perl/hints/irix_6_0.sh new file mode 100644 index 00000000000..38fe27d282c --- /dev/null +++ b/gnu/usr.bin/perl/hints/irix_6_0.sh @@ -0,0 +1,43 @@ +# irix_6.sh +# from Krishna Sethuraman, krishna@sgi.com +# Date: Wed Jan 18 11:40:08 EST 1995 +# added `-32' to force compilation in 32-bit mode. +# otherwise, copied from irix_5.sh. + +# Perl built with this hints file under IRIX 6.0.1 passes +# all tests (`make test'). + +# Tue Jan 2 14:52:36 EST 1996 +# Apparently, there's a stdio bug that can lead to memory +# corruption using perl's malloc, but not SGI's malloc. +usemymalloc='n' + +ld=ld +i_time='define' +cc="cc -32" +ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" +lddlflags="-32 -shared" + +# We don't want these libraries. Anyone know why? +set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'` +shift +libswanted="$*" +# +# The following might be of interest if you wish to try 64-bit mode: +# irix_6_64bit.sh +# Krishna Sethuraman, krishna@sgi.com +# taken from irix_5.sh . Changes from irix_5.sh: +# Olimit and nested comments (warning 1009) no longer accepted +# -OPT:fold_arith_limit so POSIX module will optimize +# no 64bit versions of sun, crypt, nsl, socket, dl dso's available +# as of IRIX 6.0.1 so omit those from libswanted line via `sed'. + +# perl 5 built with this hints file passes most tests (`make test'). +# Fails on op/subst test only. (built and tested under IRIX 6.0.1). + +# i_time='define' +# ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -woff 1009 -OPT:fold_arith_limit=1046" +# lddlflags="-shared" +# set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ sun / /' -e 's/ crypt / /' -e 's/ nsl / /' -e 's/ dl / /'` +# shift +# libswanted="$*" diff --git a/gnu/usr.bin/perl/hints/irix_6_1.sh b/gnu/usr.bin/perl/hints/irix_6_1.sh new file mode 100644 index 00000000000..38fe27d282c --- /dev/null +++ b/gnu/usr.bin/perl/hints/irix_6_1.sh @@ -0,0 +1,43 @@ +# irix_6.sh +# from Krishna Sethuraman, krishna@sgi.com +# Date: Wed Jan 18 11:40:08 EST 1995 +# added `-32' to force compilation in 32-bit mode. +# otherwise, copied from irix_5.sh. + +# Perl built with this hints file under IRIX 6.0.1 passes +# all tests (`make test'). + +# Tue Jan 2 14:52:36 EST 1996 +# Apparently, there's a stdio bug that can lead to memory +# corruption using perl's malloc, but not SGI's malloc. +usemymalloc='n' + +ld=ld +i_time='define' +cc="cc -32" +ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" +lddlflags="-32 -shared" + +# We don't want these libraries. Anyone know why? +set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'` +shift +libswanted="$*" +# +# The following might be of interest if you wish to try 64-bit mode: +# irix_6_64bit.sh +# Krishna Sethuraman, krishna@sgi.com +# taken from irix_5.sh . Changes from irix_5.sh: +# Olimit and nested comments (warning 1009) no longer accepted +# -OPT:fold_arith_limit so POSIX module will optimize +# no 64bit versions of sun, crypt, nsl, socket, dl dso's available +# as of IRIX 6.0.1 so omit those from libswanted line via `sed'. + +# perl 5 built with this hints file passes most tests (`make test'). +# Fails on op/subst test only. (built and tested under IRIX 6.0.1). + +# i_time='define' +# ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -woff 1009 -OPT:fold_arith_limit=1046" +# lddlflags="-shared" +# set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ sun / /' -e 's/ crypt / /' -e 's/ nsl / /' -e 's/ dl / /'` +# shift +# libswanted="$*" diff --git a/gnu/usr.bin/perl/hints/lynxos.sh b/gnu/usr.bin/perl/hints/lynxos.sh new file mode 100644 index 00000000000..ddffcbe3cc7 --- /dev/null +++ b/gnu/usr.bin/perl/hints/lynxos.sh @@ -0,0 +1,11 @@ +# +# LynxOS hints +# +# These hints were submitted by: +# Greg Seibert +# seibert@Lynx.COM +# + +cc='gcc' +so='none' +usemymalloc='n' diff --git a/gnu/usr.bin/perl/hints/newsos4.sh b/gnu/usr.bin/perl/hints/newsos4.sh new file mode 100644 index 00000000000..a33cb3154a3 --- /dev/null +++ b/gnu/usr.bin/perl/hints/newsos4.sh @@ -0,0 +1,34 @@ +# +# hints file for NEWS-OS 4.x +# + +echo +echo 'Compiling Tips:' +echo 'When you have found that ld complains "multiple defined" error' +echo 'on linking /lib/libdbm.a, do following instructions.' +echo ' cd /tmp (working on /tmp)' +echo ' cp /lib/libdbm.a dbm.o (copy current libdbm.a)' +echo ' ar cr libdbm.a dbm.o (make archive)' +echo ' mv /lib/libdbm.a /lib/libdbm.a.backup (backup original library)' +echo ' cp /tmp/libdbm.a /lib (copy newer one)' +echo ' ranlib /lib/libdbm.a (ranlib for later use)' +echo + +# No shared library. +so='none' +# Umm.. I like gcc. +cc='gcc' +# Configure does not find out where is libm. +plibpth='/usr/lib/cmplrs/cc' +# times() returns 'struct tms' +clocktype='struct tms' +# getgroups(2) returns integer (not gid_t) +groupstype='int' +# time(3) returns long (not time_t) +timetype='long' +# filemode type is int (not mode_t) +modetype='int' +# using sprintf(3) instead of gcvt(3) +d_Gconvert='sprintf((b),"%.*g",(n),(x))' +# No POSIX. +useposix='false' diff --git a/gnu/usr.bin/perl/hints/next_4.sh b/gnu/usr.bin/perl/hints/next_4.sh new file mode 100644 index 00000000000..316b3392123 --- /dev/null +++ b/gnu/usr.bin/perl/hints/next_4.sh @@ -0,0 +1,95 @@ +###################################################################### +# +# IMPORTANT: before you run 'make', you need to enter one of these two +# lines (depending on your shell): +# DYLD_LIBRARY_PATH=`pwd`; export DYLD_LIBRARY_PATH +# or +# setenv DYLD_LIBRARY_PATH `pwd` +# +###################################################################### + +# Posix support has been removed from NextStep +# +useposix='undef' + +libpth='/lib /usr/lib' +libswanted=' ' +libc='/NextLibrary/Frameworks/System.framework/System' + +ldflags='-dynamic -prebind' +lddlflags='-dynamic -bundle -undefined suppress' +ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC' +cccdlflags='none' +ld='cc' +#optimize='-g -O' + +###################################################################### +# MAB support +###################################################################### +# By default we will build for all architectures your development +# environment supports. If you only want to build for the platform +# you are on, simply comment or remove the line below. +# +# If you want to build for specific architectures, change the line +# below to something like +# +# archs=(m68k i386) +# +archs=`/bin/lipo -info /usr/lib/libm.a | sed -n 's/^[^:]*:[^:]*: //p'` + +# +# leave the following part alone +# +archcount=`echo $archs |wc -w` +if [ $archcount -gt 1 ] +then + for d in $archs + do + mabflags="$mabflags -arch $d" + done + ccflags="$ccflags $mabflags" + ldflags="$ldflags $mabflags" + lddlflags="$lddlflags $mabflags" +fi +###################################################################### +# END MAB support +###################################################################### + +useshprlib='true' +dlext='bundle' +so='dylib' + +# +# The default prefix would be '/usr/local'. But since many people are +# likely to have still 3.3 machines on their network, we do not want +# to overwrite possibly existing 3.3 binaries. +# You can use Configure -Dprefix=/foo/bar to override this, or simply +# remove the lines below. +# +case "$prefix" in +'') prefix='/usr/local/OPENSTEP' ;; +esac + +archname='OPENSTEP-Mach' + +# +# At least on m68k there are situations when memcmp doesn't behave +# as expected. So we'll use perl's memcmp. +# +d_sanemcmp='undef' + +d_strcoll='undef' +i_dbm='define' +i_utime='undef' +groupstype='int' +direntrytype='struct direct' + +usemymalloc='y' +clocktype='int' + +# +# On some NeXT machines, the timestamp put by ranlib is not correct, and +# this may cause useless recompiles. Fix that by adding a sleep before +# running ranlib. The '5' is an empirical number that's "long enough." +# (Thanks to Andreas Koenig <k@franz.ww.tu-berlin.de>) +ranlib='sleep 5; /bin/ranlib' diff --git a/gnu/usr.bin/perl/hints/os390.sh b/gnu/usr.bin/perl/hints/os390.sh new file mode 100644 index 00000000000..fd590eaa4e6 --- /dev/null +++ b/gnu/usr.bin/perl/hints/os390.sh @@ -0,0 +1,33 @@ +# hints/os390.sh +# OS/390 OpenEdition Release 3 Mon Sep 22 1997 thanks to: +# +# John Pfuntner <pfuntner@vnet.ibm.com> +# Len Johnson <lenjay@ibm.net> +# Bud Huff <BAHUFF@us.oracle.com> +# Peter Prymmer <pvhp@forte.com> +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# Tim Bunce <Tim.Bunce@ig.co.uk> +# +# as well as the authors of the aix.sh file +# + +cc='c89' +ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE' +optimize='none' +alignbytes=8 +usemymalloc='y' +so='a' +dlext='none' +d_shmatprototype='define' +usenm='false' +i_time='define' +i_systime='define' +d_select='undef' + +# (from aix.sh) +# uname -m output is too specific and not appropriate here +# +case "$archname" in +'') archname="$osname" ;; +esac + diff --git a/gnu/usr.bin/perl/hints/qnx.sh b/gnu/usr.bin/perl/hints/qnx.sh new file mode 100644 index 00000000000..947c98f6799 --- /dev/null +++ b/gnu/usr.bin/perl/hints/qnx.sh @@ -0,0 +1,184 @@ +#---------------------------------------------------------------- +# QNX hints +# +# As of perl5.004_04, all tests pass under: +# QNX 4.23A +# Watcom 10.6 with Beta/970211.wcc.update.tar.F +# socket3r.lib Nov21 1996. +# +# As with many unix ports, this one depends on a few "standard" +# unix utilities which are not necessarily standard for QNX. +# +# /bin/sh This is used heavily by Configure and then by +# perl itself. QNX's version is fine, but Configure +# will choke on the 16-bit version, so if you are +# running QNX 4.22, link /bin/sh to /bin32/ksh +# ar This is the standard unix library builder. +# We use wlib. With Watcom 10.6, when wlib is +# linked as "ar", it behaves like ar and all is +# fine. Under 9.5, a cover is required. One is +# included in ../qnx +# nm This is used (optionally) by configure to list +# the contents of libraries. I will generate +# a cover function on the fly in the UU directory. +# cpp Configure and perl need a way to invoke a C +# preprocessor. I have created a simple cover +# for cc which does the right thing. Without this, +# Configure will create it's own wrapper which works, +# but it doesn't handle some of the command line arguments +# that perl will throw at it. +# make You really need GNU make to compile this. GNU make +# ships by default with QNX 4.23, but you can get it +# from quics for earlier versions. +#---------------------------------------------------------------- +# Outstanding Issues: +# lib/posix.t test fails on test 17 because acos(1) != 0. +# Resolved in 970211 Beta +# lib/io_udp.t test hangs because of a bug in getsockname(). +# Fixed in latest BETA socket3r.lib +# If there is a softlink in your path, Findbin will fail. +# This is a documented feature of perl's getpwd(). +# There is currently no support for dynamically linked +# libraries. +# op/magic.t failure due to a feature of QNX which rewrites script +# names before they are executed. I think you'll find that if +# you cd `fullpath -t` before doing the make, the test will pass. +#---------------------------------------------------------------- +# At present, all QNX systems are equivalent architectures, +# so it might be reasonable to call archname=qnx rather than +# making an unnecessary distinction between AT-qnx and PCI-qnx, +# for example. +#---------------------------------------------------------------- +# These hints were submitted by: +# Norton T. Allen +# Harvard University Atmospheric Research Project +# allen@huarp.harvard.edu +# +# If you have suggestions or changes, please let me know. +#---------------------------------------------------------------- + +echo "" +echo "Some tests may fail. Please read the hints/qnx.sh file." +echo "" + +#---------------------------------------------------------------- +# QNX doesn't come with a csh and the ports of tcsh I've used +# don't work reliably: +#---------------------------------------------------------------- +csh='' +d_csh='undef' +full_csh='' + +#---------------------------------------------------------------- +# setuid scripts are secure under QNX. +# (Basically, the same race conditions apply, but assuming +# the scripts are located in a secure directory, the methods +# for exploiting the race condition are defeated because +# the loader expands the script name fully before executing +# the interpreter.) +#---------------------------------------------------------------- +d_suidsafe='define' + +#---------------------------------------------------------------- +# difftime is implemented as a preprocessor macro, so it doesn't show +# up in the libraries: +#---------------------------------------------------------------- +d_difftime='define' + +#---------------------------------------------------------------- +# strtod is in the math library, but we can't tell Configure +# about the math library or it will confuse the linker +#---------------------------------------------------------------- +d_strtod='define' + +lib_ext='3r.lib' +libc='/usr/lib/clib3r.lib' + +#---------------------------------------------------------------- +# ccflags: +# I like to turn the warnings up high, but a few common +# constructs make a lot of noise, so I turn those warnings off. +# A few still remain... +# +# HIDEMYMALLOC is necessary if using mymalloc since it is very +# tricky (though not impossible) to totally replace the watcom +# malloc/free set. +# +# unix.h is required as a general rule for unixy applications. +#---------------------------------------------------------------- +ccflags='-DHIDEMYMALLOC -mf -w4 -Wc,-wcd=202 -Wc,-wcd=203 -Wc,-wcd=302 -Wc,-fi=unix.h' + +#---------------------------------------------------------------- +# ldflags: +# If you want debugging information, you must specify -g on the +# link as well as the compile. If optimize != -g, you should +# remove this. +#---------------------------------------------------------------- +ldflags="-g -N1M" + +so='none' +selecttype='fd_set *' + +#---------------------------------------------------------------- +# Add -lunix to list of libs. This is needed mainly so the nm +# search will find funcs in the unix lib. Including unix.h should +# automatically include the library without -l. +#---------------------------------------------------------------- +libswanted="$libswanted unix" + +if [ -z "`which ar 2>/dev/null`" ]; then + cat <<-'EOF' >&4 + I don't see an 'ar', so I'm guessing you are running + Watcom 9.5 or earlier. You may want to install the ar + cover found in the qnx subdirectory of this distribution. + It might reasonably be placed in /usr/local/bin. + + EOF +fi +#---------------------------------------------------------------- +# Here is a nm script which fixes up wlib's output to look +# something like nm's, at least enough so that Configure can +# use it. +#---------------------------------------------------------------- +if [ -z "`which nm 2>/dev/null`" ]; then + cat <<-EOF + Creating a quick-and-dirty nm cover for Configure to use: + + EOF + cat >../UU/nm <<-'EOF' + #! /bin/sh + #__USAGE + #%C <lib> [<lib> ...] + # Designed to mimic Unix's nm utility to list + # defined symbols in a library + unset WLIB + for i in $*; do wlib $i; done | + awk ' + /^ / { + for (i = 1; i <= NF; i++) { + sub("_$", "", $i) + print "000000 T " $i + } + }' + EOF + chmod +x ../UU/nm +fi + +cppstdin=`which cpp 2>/dev/null` +if [ -n "$cppstdin" ]; then + cat <<-EOF >&4 + I found a cpp at $cppstdin and will assume it is a good + thing to use. If this proves to be false, there is a + thin cover for cpp in the qnx subdirectory of this + distribution which you could move into your path. + EOF + cpprun="$cppstdin" +else + cat <<-EOF >&4 + + There is a cpp cover in the qnx subdirectory of this + distribution which works a little better than the + Configure default. You may wish to copy it to + /usr/local/bin or some other suitable location. + EOF +fi diff --git a/gnu/usr.bin/perl/hints/umips.sh b/gnu/usr.bin/perl/hints/umips.sh new file mode 100644 index 00000000000..17d5ff46239 --- /dev/null +++ b/gnu/usr.bin/perl/hints/umips.sh @@ -0,0 +1,39 @@ +# hints/umips.sh +# +# Mips R3030 / Bruker AspectSation running RISC/os (UMIPS) 4.52 +# compiling with gcc 2.7.2 +# +# Created Sat Aug 17 00:17:15 MET DST 1996 +# by Guenter Schmidt <gsc@bruker.de> +# +# uname -a output looks like this: +# xxx xxx 4_52 umips mips + +# Speculative notes on getting cc to work added by +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# Tue Aug 20 21:51:49 EDT 1996 + +# Recommend the GNU C Compiler +case "$cc" in +'') echo 'gcc 2.7.2 (or later) is recommended. Use Configure -Dcc=gcc' >&4 + # The test with the native compiler not succeed: + # `sh cflags libperl.a miniperlmain.o` miniperlmain.c + # CCCMD = cc -c -I/usr/local/include -I/usr/include/bsd -DLANGUAGE_C -O + # ccom: Error: ./mg.h, line 12: redeclaration of formal parameter, sv + # int (*svt_set) (SV *sv, MAGIC* mg); + # ------------------------------------------^ + # ccom: Error: ./mg.h, line 12: redeclaration of formal parameter, mg + # This is probably a result of incomplete prototype support. + prototype=undef + ;; +esac + +# POSIX support in RiscOS is not useable +useposix='false' + +# Will give WHOA message, but the prototype are defined in the GCC inc dirs +case "$cc" in +*gcc*) d_shmatprototype='define' ;; +esac + +glibpth="$glibpth /usr/lib/cmplrs/cc" diff --git a/gnu/usr.bin/perl/hints/unicosmk.sh b/gnu/usr.bin/perl/hints/unicosmk.sh new file mode 100644 index 00000000000..90784b5b39f --- /dev/null +++ b/gnu/usr.bin/perl/hints/unicosmk.sh @@ -0,0 +1,3 @@ +optimize="-O1" +d_setregid='undef' +d_setreuid='undef' diff --git a/gnu/usr.bin/perl/lib/CGI.pm b/gnu/usr.bin/perl/lib/CGI.pm new file mode 100644 index 00000000000..9967a42cf67 --- /dev/null +++ b/gnu/usr.bin/perl/lib/CGI.pm @@ -0,0 +1,5108 @@ +package CGI; +require 5.001; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +# You can run this file through either pod2man or pod2html to produce pretty +# documentation in manual or html file format (these utilities are part of the +# Perl 5 distribution). + +# Copyright 1995-1997 Lincoln D. Stein. All rights reserved. +# It may be used and modified freely, but I do request that this copyright +# notice remain attached to the file. You may modify this module as you +# wish, but if you redistribute a modified version, please attach a note +# listing the modifications you have made. + +# The most recent version and complete docs are available at: +# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html +# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ + +# Set this to 1 to enable copious autoloader debugging messages +$AUTOLOAD_DEBUG=0; + +# Set this to 1 to enable NPH scripts +# or: +# 1) use CGI qw(:nph) +# 2) $CGI::nph(1) +# 3) print header(-nph=>1) +$NPH=0; + +# Set this to 1 to make the temporary files created +# during file uploads safe from prying eyes +# or do... +# 1) use CGI qw(:private_tempfiles) +# 2) $CGI::private_tempfiles(1); +$PRIVATE_TEMPFILES=0; + +$CGI::revision = '$Id: CGI.pm,v 1.1 1997/11/30 07:56:38 millert Exp $'; +$CGI::VERSION='2.36'; + +# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG +# $OS = 'UNIX'; +# $OS = 'MACINTOSH'; +# $OS = 'WINDOWS'; +# $OS = 'VMS'; +# $OS = 'OS2'; + +# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES. +# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING. +# $TempFile::TMPDIRECTORY = '/usr/tmp'; + +# ------------------ START OF THE LIBRARY ------------ + +# FIGURE OUT THE OS WE'RE RUNNING UNDER +# Some systems support the $^O variable. If not +# available then require() the Config library +unless ($OS) { + unless ($OS = $^O) { + require Config; + $OS = $Config::Config{'osname'}; + } +} +if ($OS=~/Win/i) { + $OS = 'WINDOWS'; +} elsif ($OS=~/vms/i) { + $OS = 'VMS'; +} elsif ($OS=~/Mac/i) { + $OS = 'MACINTOSH'; +} elsif ($OS=~/os2/i) { + $OS = 'OS2'; +} else { + $OS = 'UNIX'; +} + +# Some OS logic. Binary mode enabled on DOS, NT and VMS +$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/; + +# This is the default class for the CGI object to use when all else fails. +$DefaultClass = 'CGI' unless defined $CGI::DefaultClass; +# This is where to look for autoloaded routines. +$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass; + +# The path separator is a slash, backslash or semicolon, depending +# on the paltform. +$SL = { + UNIX=>'/', + OS2=>'\\', + WINDOWS=>'\\', + MACINTOSH=>':', + VMS=>'\\' + }->{$OS}; + +# Turn on NPH scripts by default when running under IIS server! +$NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; + +# Turn on special checking for Doug MacEachern's modperl +if (defined($ENV{'GATEWAY_INTERFACE'}) && ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/)) { + $NPH++; + $| = 1; + $SEQNO = 1; +} + +# This is really "\r\n", but the meaning of \n is different +# in MacPerl, so we resort to octal here. +$CRLF = "\015\012"; + +if ($needs_binmode) { + $CGI::DefaultClass->binmode(main::STDOUT); + $CGI::DefaultClass->binmode(main::STDIN); + $CGI::DefaultClass->binmode(main::STDERR); +} + +# Cute feature, but it broke when the overload mechanism changed... +# %OVERLOAD = ('""'=>'as_string'); + +%EXPORT_TAGS = ( + ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em + tt i b blockquote pre img a address cite samp dfn html head + base body link nextid title meta kbd start_html end_html + input Select option/], + ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont style span/], + ':netscape'=>[qw/blink frameset frame script font fontsize center/], + ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group + submit reset defaults radio_group popup_menu button autoEscape + scrolling_list image_button start_form end_form startform endform + start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/], + ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump + raw_cookie request_method query_string accept user_agent remote_host + remote_addr referer server_name server_software server_port server_protocol + virtual_host remote_ident auth_type http use_named_parameters + remote_user user_name header redirect import_names put/], + ':ssl' => [qw/https/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/], + ':html' => [qw/:html2 :html3 :netscape/], + ':standard' => [qw/:html2 :form :cgi/], + ':all' => [qw/:html2 :html3 :netscape :form :cgi/] + ); + +# to import symbols into caller +sub import { + my $self = shift; + my ($callpack, $callfile, $callline) = caller; + foreach (@_) { + $NPH++, next if $_ eq ':nph'; + $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles'; + foreach (&expand_tags($_)) { + tr/a-zA-Z0-9_//cd; # don't allow weird function names + $EXPORT{$_}++; + } + } + # To allow overriding, search through the packages + # Till we find one in which the correct subroutine is defined. + my @packages = ($self,@{"$self\:\:ISA"}); + foreach $sym (keys %EXPORT) { + my $pck; + my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass; + foreach $pck (@packages) { + if (defined(&{"$pck\:\:$sym"})) { + $def = $pck; + last; + } + } + *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; + } +} + +sub expand_tags { + my($tag) = @_; + my(@r); + return ($tag) unless $EXPORT_TAGS{$tag}; + foreach (@{$EXPORT_TAGS{$tag}}) { + push(@r,&expand_tags($_)); + } + return @r; +} + +#### Method: new +# The new routine. This will check the current environment +# for an existing query string, and initialize itself, if so. +#### +sub new { + my($class,$initializer) = @_; + my $self = {}; + bless $self,ref $class || $class || $DefaultClass; + $CGI::DefaultClass->_reset_globals() if $MOD_PERL; + $initializer = to_filehandle($initializer) if $initializer; + $self->init($initializer); + return $self; +} + +# We provide a DESTROY method so that the autoloader +# doesn't bother trying to find it. +sub DESTROY { } + +#### Method: param +# Returns the value(s)of a named parameter. +# If invoked in a list context, returns the +# entire list. Otherwise returns the first +# member of the list. +# If name is not provided, return a list of all +# the known parameters names available. +# If more than one argument is provided, the +# second and subsequent arguments are used to +# set the value of the parameter. +#### +sub param { + my($self,@p) = self_or_default(@_); + return $self->all_parameters unless @p; + my($name,$value,@other); + + # For compatibility between old calling style and use_named_parameters() style, + # we have to special case for a single parameter present. + if (@p > 1) { + ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); + my(@values); + + if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) { + @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); + } else { + foreach ($value,@other) { + push(@values,$_) if defined($_); + } + } + # If values is provided, then we set it. + if (@values) { + $self->add_parameter($name); + $self->{$name}=[@values]; + } + } else { + $name = $p[0]; + } + + return () unless defined($name) && $self->{$name}; + return wantarray ? @{$self->{$name}} : $self->{$name}->[0]; +} + +#### Method: delete +# Deletes the named parameter entirely. +#### +sub delete { + my($self,$name) = self_or_default(@_); + delete $self->{$name}; + delete $self->{'.fieldnames'}->{$name}; + @{$self->{'.parameters'}}=grep($_ ne $name,$self->param()); + return wantarray ? () : undef; +} + +sub self_or_default { + return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI'); + unless (defined($_[0]) && + ref($_[0]) && + (ref($_[0]) eq 'CGI' || + eval "\$_[0]->isaCGI()")) { # optimize for the common case + $CGI::DefaultClass->_reset_globals() + if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request(); + $Q = $CGI::DefaultClass->new unless defined($Q); + unshift(@_,$Q); + } + return @_; +} + +sub _new_request { + return undef unless (defined(Apache->seqno()) or eval { require Apache }); + if (Apache->seqno() != $SEQNO) { + $SEQNO = Apache->seqno(); + return 1; + } else { + return undef; + } +} + +sub _reset_globals { + undef $Q; + undef @QUERY_PARAM; +} + +sub self_or_CGI { + local $^W=0; # prevent a warning + if (defined($_[0]) && + (substr(ref($_[0]),0,3) eq 'CGI' + || eval "\$_[0]->isaCGI()")) { + return @_; + } else { + return ($DefaultClass,@_); + } +} + +sub isaCGI { + return 1; +} + +#### Method: import_names +# Import all parameters into the given namespace. +# Assumes namespace 'Q' if not specified +#### +sub import_names { + my($self,$namespace) = self_or_default(@_); + $namespace = 'Q' unless defined($namespace); + die "Can't import names into 'main'\n" + if $namespace eq 'main'; + my($param,@value,$var); + foreach $param ($self->param) { + # protect against silly names + ($var = $param)=~tr/a-zA-Z0-9_/_/c; + $var = "${namespace}::$var"; + @value = $self->param($param); + @{$var} = @value; + ${$var} = $value[0]; + } +} + +#### Method: use_named_parameters +# Force CGI.pm to use named parameter-style method calls +# rather than positional parameters. The same effect +# will happen automatically if the first parameter +# begins with a -. +sub use_named_parameters { + my($self,$use_named) = self_or_default(@_); + return $self->{'.named'} unless defined ($use_named); + + # stupidity to avoid annoying warnings + return $self->{'.named'}=$use_named; +} + +######################################## +# THESE METHODS ARE MORE OR LESS PRIVATE +# GO TO THE __DATA__ SECTION TO SEE MORE +# PUBLIC METHODS +######################################## + +# Initialize the query object from the environment. +# If a parameter list is found, this object will be set +# to an associative array in which parameter names are keys +# and the values are stored as lists +# If a keyword list is found, this method creates a bogus +# parameter list with the single parameter 'keywords'. + +sub init { + my($self,$initializer) = @_; + my($query_string,@lines); + my($meth) = ''; + + # if we get called more than once, we want to initialize + # ourselves from the original query (which may be gone + # if it was read from STDIN originally.) + if (defined(@QUERY_PARAM) && !defined($initializer)) { + + foreach (@QUERY_PARAM) { + $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_}); + } + return; + } + + $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); + + # If initializer is defined, then read parameters + # from it. + METHOD: { + if (defined($initializer)) { + + if (ref($initializer) && ref($initializer) eq 'HASH') { + foreach (keys %$initializer) { + $self->param('-name'=>$_,'-value'=>$initializer->{$_}); + } + last METHOD; + } + + $initializer = $$initializer if ref($initializer); + if (defined(fileno($initializer))) { + while (<$initializer>) { + chomp; + last if /^=/; + push(@lines,$_); + } + # massage back into standard format + if ("@lines" =~ /=/) { + $query_string=join("&",@lines); + } else { + $query_string=join("+",@lines); + } + last METHOD; + } + $query_string = $initializer; + last METHOD; + } + # If method is GET or HEAD, fetch the query from + # the environment. + if ($meth=~/^(GET|HEAD)$/) { + $query_string = $ENV{'QUERY_STRING'}; + last METHOD; + } + + # If the method is POST, fetch the query from standard + # input. + if ($meth eq 'POST') { + + if (defined($ENV{'CONTENT_TYPE'}) + && + $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) { + my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/; + $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'}); + + } else { + + $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0) + if $ENV{'CONTENT_LENGTH'} > 0; + + } + # Some people want to have their cake and eat it too! + # Uncomment this line to have the contents of the query string + # APPENDED to the POST data. + # $query_string .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'}; + last METHOD; + } + + # If neither is set, assume we're being debugged offline. + # Check the command line and then the standard input for data. + # We use the shellwords package in order to behave the way that + # UN*X programmers expect. + $query_string = &read_from_cmdline; + } + + # We now have the query string in hand. We do slightly + # different things for keyword lists and parameter lists. + if ($query_string) { + if ($query_string =~ /=/) { + $self->parse_params($query_string); + } else { + $self->add_parameter('keywords'); + $self->{'keywords'} = [$self->parse_keywordlist($query_string)]; + } + } + + # Special case. Erase everything if there is a field named + # .defaults. + if ($self->param('.defaults')) { + undef %{$self}; + } + + # Associative array containing our defined fieldnames + $self->{'.fieldnames'} = {}; + foreach ($self->param('.cgifields')) { + $self->{'.fieldnames'}->{$_}++; + } + + # Clear out our default submission button flag if present + $self->delete('.submit'); + $self->delete('.cgifields'); + $self->save_request unless $initializer; + +} + + +# FUNCTIONS TO OVERRIDE: + +# Turn a string into a filehandle +sub to_filehandle { + my $string = shift; + if ($string && !ref($string)) { + my($package) = caller(1); + my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string"; + return $tmp if defined(fileno($tmp)); + } + return $string; +} + +# Create a new multipart buffer +sub new_MultipartBuffer { + my($self,$boundary,$length,$filehandle) = @_; + return MultipartBuffer->new($self,$boundary,$length,$filehandle); +} + +# Read data from a file handle +sub read_from_client { + my($self, $fh, $buff, $len, $offset) = @_; + local $^W=0; # prevent a warning + return read($fh, $$buff, $len, $offset); +} + +# put a filehandle into binary mode (DOS) +sub binmode { + binmode($_[1]); +} + +# send output to the browser +sub put { + my($self,@p) = self_or_default(@_); + $self->print(@p); +} + +# print to standard output (for overriding in mod_perl) +sub print { + shift; + CORE::print(@_); +} + +# unescape URL-encoded data +sub unescape { + my($todecode) = @_; + $todecode =~ tr/+/ /; # pluses become spaces + $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; + return $todecode; +} + +# URL-encode data +sub escape { + my($toencode) = @_; + $toencode=~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg; + return $toencode; +} + +sub save_request { + my($self) = @_; + # We're going to play with the package globals now so that if we get called + # again, we initialize ourselves in exactly the same way. This allows + # us to have several of these objects. + @QUERY_PARAM = $self->param; # save list of parameters + foreach (@QUERY_PARAM) { + $QUERY_PARAM{$_}=$self->{$_}; + } +} + +sub parse_keywordlist { + my($self,$tosplit) = @_; + $tosplit = &unescape($tosplit); # unescape the keywords + $tosplit=~tr/+/ /; # pluses to spaces + my(@keywords) = split(/\s+/,$tosplit); + return @keywords; +} + +sub parse_params { + my($self,$tosplit) = @_; + my(@pairs) = split('&',$tosplit); + my($param,$value); + foreach (@pairs) { + ($param,$value) = split('='); + $param = &unescape($param); + $value = &unescape($value); + $self->add_parameter($param); + push (@{$self->{$param}},$value); + } +} + +sub add_parameter { + my($self,$param)=@_; + push (@{$self->{'.parameters'}},$param) + unless defined($self->{$param}); +} + +sub all_parameters { + my $self = shift; + return () unless defined($self) && $self->{'.parameters'}; + return () unless @{$self->{'.parameters'}}; + return @{$self->{'.parameters'}}; +} + +#### Method as_string +# +# synonym for "dump" +#### +sub as_string { + &dump(@_); +} + +sub AUTOLOAD { + print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG; + my($func) = $AUTOLOAD; + my($pack,$func_name) = $func=~/(.+)::([^:]+)$/; + $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass + unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"}); + + my($sub) = \%{"$pack\:\:SUBS"}; + unless (%$sub) { + my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"}; + eval "package $pack; $$auto"; + die $@ if $@; + } + my($code) = $sub->{$func_name}; + + $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY'); + if (!$code) { + if ($EXPORT{':any'} || + $EXPORT{$func_name} || + (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html'))) + && $EXPORT_OK{$func_name}) { + $code = $sub->{'HTML_FUNC'}; + $code=~s/func_name/$func_name/mg; + } + } + die "Undefined subroutine $AUTOLOAD\n" unless $code; + eval "package $pack; $code"; + if ($@) { + $@ =~ s/ at .*\n//; + die $@; + } + goto &{"$pack\:\:$func_name"}; +} + +# PRIVATE SUBROUTINE +# Smart rearrangement of parameters to allow named parameter +# calling. We do the rearangement if: +# 1. The first parameter begins with a - +# 2. The use_named_parameters() method returns true +sub rearrange { + my($self,$order,@param) = @_; + return () unless @param; + + return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-') + || $self->use_named_parameters; + + my $i; + for ($i=0;$i<@param;$i+=2) { + $param[$i]=~s/^\-//; # get rid of initial - if present + $param[$i]=~tr/a-z/A-Z/; # parameters are upper case + } + + my(%param) = @param; # convert into associative array + my(@return_array); + + my($key)=''; + foreach $key (@$order) { + my($value); + # this is an awful hack to fix spurious warnings when the + # -w switch is set. + if (ref($key) && ref($key) eq 'ARRAY') { + foreach (@$key) { + last if defined($value); + $value = $param{$_}; + delete $param{$_}; + } + } else { + $value = $param{$key}; + delete $param{$key}; + } + push(@return_array,$value); + } + push (@return_array,$self->make_attributes(\%param)) if %param; + return (@return_array); +} + +############################################################################### +################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### +############################################################################### +$AUTOLOADED_ROUTINES = ''; # get rid of -w warning +$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; + +%SUBS = ( + +'URL_ENCODED'=> <<'END_OF_FUNC', +sub URL_ENCODED { 'application/x-www-form-urlencoded'; } +END_OF_FUNC + +'MULTIPART' => <<'END_OF_FUNC', +sub MULTIPART { 'multipart/form-data'; } +END_OF_FUNC + +'HTML_FUNC' => <<'END_OF_FUNC', +sub func_name { + + # handle various cases in which we're called + # most of this bizarre stuff is to avoid -w errors + shift if $_[0] && + (!ref($_[0]) && $_[0] eq $CGI::DefaultClass) || + (ref($_[0]) && + (substr(ref($_[0]),0,3) eq 'CGI' || + eval "\$_[0]->isaCGI()")); + + my($attr) = ''; + if (ref($_[0]) && ref($_[0]) eq 'HASH') { + my(@attr) = CGI::make_attributes('',shift); + $attr = " @attr" if @attr; + } + my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E"); + return $tag unless @_; + if (ref($_[0]) eq 'ARRAY') { + my(@r); + foreach (@{$_[0]}) { + push(@r,"$tag$_$untag"); + } + return "@r"; + } else { + return "$tag@_$untag"; + } +} +END_OF_FUNC + +#### Method: keywords +# Keywords acts a bit differently. Calling it in a list context +# returns the list of keywords. +# Calling it in a scalar context gives you the size of the list. +#### +'keywords' => <<'END_OF_FUNC', +sub keywords { + my($self,@values) = self_or_default(@_); + # If values is provided, then we set it. + $self->{'keywords'}=[@values] if @values; + my(@result) = @{$self->{'keywords'}}; + @result; +} +END_OF_FUNC + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines +'ReadParse' => <<'END_OF_FUNC', +sub ReadParse { + local(*in); + if (@_) { + *in = $_[0]; + } else { + my $pkg = caller(); + *in=*{"${pkg}::in"}; + } + tie(%in,CGI); +} +END_OF_FUNC + +'PrintHeader' => <<'END_OF_FUNC', +sub PrintHeader { + my($self) = self_or_default(@_); + return $self->header(); +} +END_OF_FUNC + +'HtmlTop' => <<'END_OF_FUNC', +sub HtmlTop { + my($self,@p) = self_or_default(@_); + return $self->start_html(@p); +} +END_OF_FUNC + +'HtmlBot' => <<'END_OF_FUNC', +sub HtmlBot { + my($self,@p) = self_or_default(@_); + return $self->end_html(@p); +} +END_OF_FUNC + +'SplitParam' => <<'END_OF_FUNC', +sub SplitParam { + my ($param) = @_; + my (@params) = split ("\0", $param); + return (wantarray ? @params : $params[0]); +} +END_OF_FUNC + +'MethGet' => <<'END_OF_FUNC', +sub MethGet { + return request_method() eq 'GET'; +} +END_OF_FUNC + +'MethPost' => <<'END_OF_FUNC', +sub MethPost { + return request_method() eq 'POST'; +} +END_OF_FUNC + +'TIEHASH' => <<'END_OF_FUNC', +sub TIEHASH { + return new CGI; +} +END_OF_FUNC + +'STORE' => <<'END_OF_FUNC', +sub STORE { + $_[0]->param($_[1],split("\0",$_[2])); +} +END_OF_FUNC + +'FETCH' => <<'END_OF_FUNC', +sub FETCH { + return $_[0] if $_[1] eq 'CGI'; + return undef unless defined $_[0]->param($_[1]); + return join("\0",$_[0]->param($_[1])); +} +END_OF_FUNC + +'FIRSTKEY' => <<'END_OF_FUNC', +sub FIRSTKEY { + $_[0]->{'.iterator'}=0; + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} +END_OF_FUNC + +'NEXTKEY' => <<'END_OF_FUNC', +sub NEXTKEY { + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} +END_OF_FUNC + +'EXISTS' => <<'END_OF_FUNC', +sub EXISTS { + exists $_[0]->{$_[1]}; +} +END_OF_FUNC + +'DELETE' => <<'END_OF_FUNC', +sub DELETE { + $_[0]->delete($_[1]); +} +END_OF_FUNC + +'CLEAR' => <<'END_OF_FUNC', +sub CLEAR { + %{$_[0]}=(); +} +#### +END_OF_FUNC + +#### +# Append a new value to an existing query +#### +'append' => <<'EOF', +sub append { + my($self,@p) = @_; + my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p); + my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); + if (@values) { + $self->add_parameter($name); + push(@{$self->{$name}},@values); + } + return $self->param($name); +} +EOF + +#### Method: delete_all +# Delete all parameters +#### +'delete_all' => <<'EOF', +sub delete_all { + my($self) = self_or_default(@_); + undef %{$self}; +} +EOF + +#### Method: autoescape +# If you want to turn off the autoescaping features, +# call this method with undef as the argument +'autoEscape' => <<'END_OF_FUNC', +sub autoEscape { + my($self,$escape) = self_or_default(@_); + $self->{'dontescape'}=!$escape; +} +END_OF_FUNC + + +#### Method: version +# Return the current version +#### +'version' => <<'END_OF_FUNC', +sub version { + return $VERSION; +} +END_OF_FUNC + +'make_attributes' => <<'END_OF_FUNC', +sub make_attributes { + my($self,$attr) = @_; + return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; + my(@att); + foreach (keys %{$attr}) { + my($key) = $_; + $key=~s/^\-//; # get rid of initial - if present + $key=~tr/a-z/A-Z/; # parameters are upper case + push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/); + } + return @att; +} +END_OF_FUNC + +#### Method: dump +# Returns a string in which all the known parameter/value +# pairs are represented as nested lists, mainly for the purposes +# of debugging. +#### +'dump' => <<'END_OF_FUNC', +sub dump { + my($self) = self_or_default(@_); + my($param,$value,@result); + return '<UL></UL>' unless $self->param; + push(@result,"<UL>"); + foreach $param ($self->param) { + my($name)=$self->escapeHTML($param); + push(@result,"<LI><STRONG>$param</STRONG>"); + push(@result,"<UL>"); + foreach $value ($self->param($param)) { + $value = $self->escapeHTML($value); + push(@result,"<LI>$value"); + } + push(@result,"</UL>"); + } + push(@result,"</UL>\n"); + return join("\n",@result); +} +END_OF_FUNC + + +#### Method: save +# Write values out to a filehandle in such a way that they can +# be reinitialized by the filehandle form of the new() method +#### +'save' => <<'END_OF_FUNC', +sub save { + my($self,$filehandle) = self_or_default(@_); + my($param); + my($package) = caller; +# Check that this still works! +# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; + $filehandle = to_filehandle($filehandle); + foreach $param ($self->param) { + my($escaped_param) = &escape($param); + my($value); + foreach $value ($self->param($param)) { + print $filehandle "$escaped_param=",escape($value),"\n"; + } + } + print $filehandle "=\n"; # end of record +} +END_OF_FUNC + + +#### Method: header +# Return a Content-Type: style header +# +#### +'header' => <<'END_OF_FUNC', +sub header { + my($self,@p) = self_or_default(@_); + my(@header); + + my($type,$status,$cookie,$target,$expires,$nph,@other) = + $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p); + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + foreach (@other) { + next unless my($header,$value) = /([^\s=]+)=(.+)/; + substr($header,1,1000)=~tr/A-Z/a-z/; + ($value)=$value=~/^"(.*)"$/; + $_ = "$header: $value"; + } + + $type = $type || 'text/html'; + + push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $NPH; + push(@header,"Status: $status") if $status; + push(@header,"Window-target: $target") if $target; + # push all the cookies -- there may be several + if ($cookie) { + my(@cookie) = ref($cookie) ? @{$cookie} : $cookie; + foreach (@cookie) { + push(@header,"Set-cookie: $_"); + } + } + # if the user indicates an expiration time, then we need + # both an Expires and a Date header (so that the browser is + # uses OUR clock) + push(@header,"Expires: " . &date(&expire_calc($expires),'http')) + if $expires; + push(@header,"Date: " . &date(&expire_calc(0),'http')) if $expires || $cookie; + push(@header,"Pragma: no-cache") if $self->cache(); + push(@header,@other); + push(@header,"Content-type: $type"); + + my $header = join($CRLF,@header); + return $header . "${CRLF}${CRLF}"; +} +END_OF_FUNC + + +#### Method: cache +# Control whether header() will produce the no-cache +# Pragma directive. +#### +'cache' => <<'END_OF_FUNC', +sub cache { + my($self,$new_value) = self_or_default(@_); + $new_value = '' unless $new_value; + if ($new_value ne '') { + $self->{'cache'} = $new_value; + } + return $self->{'cache'}; +} +END_OF_FUNC + + +#### Method: redirect +# Return a Location: style header +# +#### +'redirect' => <<'END_OF_FUNC', +sub redirect { + my($self,@p) = self_or_default(@_); + my($url,$target,$cookie,$nph,@other) = $self->rearrange([[URI,URL],TARGET,COOKIE,NPH],@p); + $url = $url || $self->self_url; + my(@o); + foreach (@other) { push(@o,split("=")); } + if($MOD_PERL or exists $self->{'.req'}) { + my $r = $self->{'.req'} || Apache->request; + $r->header_out(Location => $url); + $r->err_header_out(Location => $url); + $r->status(302); + return; + } + push(@o, + '-Status'=>'302 Found', + '-Location'=>$url, + '-URI'=>$url, + '-nph'=>($nph||$NPH)); + push(@o,'-Target'=>$target) if $target; + push(@o,'-Cookie'=>$cookie) if $cookie; + return $self->header(@o); +} +END_OF_FUNC + + +#### Method: start_html +# Canned HTML header +# +# Parameters: +# $title -> (optional) The title for this HTML document (-title) +# $author -> (optional) e-mail address of the author (-author) +# $base -> (optional) if set to true, will enter the BASE address of this document +# for resolving relative references (-base) +# $xbase -> (optional) alternative base at some remote location (-xbase) +# $target -> (optional) target window to load all links into (-target) +# $script -> (option) Javascript code (-script) +# $no_script -> (option) Javascript <noscript> tag (-noscript) +# $meta -> (optional) Meta information tags +# $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag +# (a scalar or array ref) +# $style -> (optional) reference to an external style sheet +# @other -> (optional) any other named parameters you'd like to incorporate into +# the <BODY> tag. +#### +'start_html' => <<'END_OF_FUNC', +sub start_html { + my($self,@p) = &self_or_default(@_); + my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,@other) = + $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE],@p); + + # strangely enough, the title needs to be escaped as HTML + # while the author needs to be escaped as a URL + $title = $self->escapeHTML($title || 'Untitled Document'); + $author = $self->escapeHTML($author); + my(@result); + push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">'); + push(@result,"<HTML><HEAD><TITLE>$title</TITLE>"); + push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author; + + if ($base || $xbase || $target) { + my $href = $xbase || $self->url(); + my $t = $target ? qq/ TARGET="$target"/ : ''; + push(@result,qq/<BASE HREF="$href"$t>/); + } + + if ($meta && ref($meta) && (ref($meta) eq 'HASH')) { + foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); } + } + + push(@result,ref($head) ? @$head : $head) if $head; + + # handle various types of -style parameters + if ($style) { + if (ref($style)) { + my($src,$code,@other) = + $self->rearrange([SRC,CODE], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($style) eq 'ARRAY' ? @$style : %$style); + push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src; + push(@result,style($code)) if $code; + } else { + push(@result,style($style)) + } + } + + # handle -script parameter + if ($script) { + my($src,$code,$language); + if (ref($script)) { # script is a hash + ($src,$code,$language) = + $self->rearrange([SRC,CODE,LANGUAGE], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($style) eq 'ARRAY' ? @$script : %$script); + + } else { + ($src,$code,$language) = ('',$script,'JavaScript'); + } + my(@satts); + push(@satts,'src'=>$src) if $src; + push(@satts,'language'=>$language || 'JavaScript'); + $code = "<!-- Hide script\n$code\n// End script hiding -->" + if $code && $language=~/javascript/i; + $code = "<!-- Hide script\n$code\n\# End script hiding -->" + if $code && $language=~/perl/i; + push(@result,script({@satts},$code)); + } + + # handle -noscript parameter + push(@result,<<END) if $noscript; +<NOSCRIPT> +$noscript +</NOSCRIPT> +END + ; + my($other) = @other ? " @other" : ''; + push(@result,"</HEAD><BODY$other>"); + return join("\n",@result); +} +END_OF_FUNC + + +#### Method: end_html +# End an HTML document. +# Trivial method for completeness. Just returns "</BODY>" +#### +'end_html' => <<'END_OF_FUNC', +sub end_html { + return "</BODY></HTML>"; +} +END_OF_FUNC + + +################################ +# METHODS USED IN BUILDING FORMS +################################ + +#### Method: isindex +# Just prints out the isindex tag. +# Parameters: +# $action -> optional URL of script to run +# Returns: +# A string containing a <ISINDEX> tag +'isindex' => <<'END_OF_FUNC', +sub isindex { + my($self,@p) = self_or_default(@_); + my($action,@other) = $self->rearrange([ACTION],@p); + $action = qq/ACTION="$action"/ if $action; + my($other) = @other ? " @other" : ''; + return "<ISINDEX $action$other>"; +} +END_OF_FUNC + + +#### Method: startform +# Start a form +# Parameters: +# $method -> optional submission method to use (GET or POST) +# $action -> optional URL of script to run +# $enctype ->encoding to use (URL_ENCODED or MULTIPART) +'startform' => <<'END_OF_FUNC', +sub startform { + my($self,@p) = self_or_default(@_); + + my($method,$action,$enctype,@other) = + $self->rearrange([METHOD,ACTION,ENCTYPE],@p); + + $method = $method || 'POST'; + $enctype = $enctype || &URL_ENCODED; + $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ? + 'ACTION="'.$self->script_name.'"' : ''; + my($other) = @other ? " @other" : ''; + $self->{'.parametersToAdd'}={}; + return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/; +} +END_OF_FUNC + + +#### Method: start_form +# synonym for startform +'start_form' => <<'END_OF_FUNC', +sub start_form { + &startform; +} +END_OF_FUNC + + +#### Method: start_multipart_form +# synonym for startform +'start_multipart_form' => <<'END_OF_FUNC', +sub start_multipart_form { + my($self,@p) = self_or_default(@_); + if ($self->use_named_parameters || + (defined($param[0]) && substr($param[0],0,1) eq '-')) { + my(%p) = @p; + $p{'-enctype'}=&MULTIPART; + return $self->startform(%p); + } else { + my($method,$action,@other) = + $self->rearrange([METHOD,ACTION],@p); + return $self->startform($method,$action,&MULTIPART,@other); + } +} +END_OF_FUNC + + +#### Method: endform +# End a form +'endform' => <<'END_OF_FUNC', +sub endform { + my($self,@p) = self_or_default(@_); + return ($self->get_fields,"</FORM>"); +} +END_OF_FUNC + + +#### Method: end_form +# synonym for endform +'end_form' => <<'END_OF_FUNC', +sub end_form { + &endform; +} +END_OF_FUNC + + +#### Method: textfield +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a <INPUT TYPE="text"> field +# +'textfield' => <<'END_OF_FUNC', +sub textfield { + my($self,@p) = self_or_default(@_); + my($name,$default,$size,$maxlength,$override,@other) = + $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); + + my $current = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $current = defined($current) ? $self->escapeHTML($current) : ''; + $name = defined($name) ? $self->escapeHTML($name) : ''; + my($s) = defined($size) ? qq/ SIZE=$size/ : ''; + my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; + my($other) = @other ? " @other" : ''; + return qq/<INPUT TYPE="text" NAME="$name" VALUE="$current"$s$m$other>/; +} +END_OF_FUNC + + +#### Method: filefield +# Parameters: +# $name -> Name of the file upload field +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a <INPUT TYPE="text"> field +# +'filefield' => <<'END_OF_FUNC', +sub filefield { + my($self,@p) = self_or_default(@_); + + my($name,$default,$size,$maxlength,$override,@other) = + $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); + + $current = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $name = defined($name) ? $self->escapeHTML($name) : ''; + my($s) = defined($size) ? qq/ SIZE=$size/ : ''; + my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; + $current = defined($current) ? $self->escapeHTML($current) : ''; + $other = ' ' . join(" ",@other); + return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/; +} +END_OF_FUNC + + +#### Method: password +# Create a "secret password" entry field +# Parameters: +# $name -> Name of the field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characters. +# $maxlength -> Optional maximum characters that can be entered. +# Returns: +# A string containing a <INPUT TYPE="password"> field +# +'password_field' => <<'END_OF_FUNC', +sub password_field { + my ($self,@p) = self_or_default(@_); + + my($name,$default,$size,$maxlength,$override,@other) = + $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p); + + my($current) = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $name = defined($name) ? $self->escapeHTML($name) : ''; + $current = defined($current) ? $self->escapeHTML($current) : ''; + my($s) = defined($size) ? qq/ SIZE=$size/ : ''; + my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : ''; + my($other) = @other ? " @other" : ''; + return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/; +} +END_OF_FUNC + + +#### Method: textarea +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $rows -> Optional number of rows in text area +# $columns -> Optional number of columns in text area +# Returns: +# A string containing a <TEXTAREA></TEXTAREA> tag +# +'textarea' => <<'END_OF_FUNC', +sub textarea { + my($self,@p) = self_or_default(@_); + + my($name,$default,$rows,$cols,$override,@other) = + $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p); + + my($current)= $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $name = defined($name) ? $self->escapeHTML($name) : ''; + $current = defined($current) ? $self->escapeHTML($current) : ''; + my($r) = $rows ? " ROWS=$rows" : ''; + my($c) = $cols ? " COLS=$cols" : ''; + my($other) = @other ? " @other" : ''; + return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>}; +} +END_OF_FUNC + + +#### Method: button +# Create a javascript button. +# Parameters: +# $name -> (optional) Name for the button. (-name) +# $value -> (optional) Value of the button when selected (and visible name) (-value) +# $onclick -> (optional) Text of the JavaScript to run when the button is +# clicked. +# Returns: +# A string containing a <INPUT TYPE="button"> tag +#### +'button' => <<'END_OF_FUNC', +sub button { + my($self,@p) = self_or_default(@_); + + my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL], + [ONCLICK,SCRIPT]],@p); + + $label=$self->escapeHTML($label); + $value=$self->escapeHTML($value); + $script=$self->escapeHTML($script); + + my($name) = ''; + $name = qq/ NAME="$label"/ if $label; + $value = $value || $label; + my($val) = ''; + $val = qq/ VALUE="$value"/ if $value; + $script = qq/ ONCLICK="$script"/ if $script; + my($other) = @other ? " @other" : ''; + return qq/<INPUT TYPE="button"$name$val$script$other>/; +} +END_OF_FUNC + + +#### Method: submit +# Create a "submit query" button. +# Parameters: +# $name -> (optional) Name for the button. +# $value -> (optional) Value of the button when selected (also doubles as label). +# $label -> (optional) Label printed on the button(also doubles as the value). +# Returns: +# A string containing a <INPUT TYPE="submit"> tag +#### +'submit' => <<'END_OF_FUNC', +sub submit { + my($self,@p) = self_or_default(@_); + + my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p); + + $label=$self->escapeHTML($label); + $value=$self->escapeHTML($value); + + my($name) = ' NAME=".submit"'; + $name = qq/ NAME="$label"/ if $label; + $value = $value || $label; + my($val) = ''; + $val = qq/ VALUE="$value"/ if defined($value); + my($other) = @other ? " @other" : ''; + return qq/<INPUT TYPE="submit"$name$val$other>/; +} +END_OF_FUNC + + +#### Method: reset +# Create a "reset" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a <INPUT TYPE="reset"> tag +#### +'reset' => <<'END_OF_FUNC', +sub reset { + my($self,@p) = self_or_default(@_); + my($label,@other) = $self->rearrange([NAME],@p); + $label=$self->escapeHTML($label); + my($value) = defined($label) ? qq/ VALUE="$label"/ : ''; + my($other) = @other ? " @other" : ''; + return qq/<INPUT TYPE="reset"$value$other>/; +} +END_OF_FUNC + + +#### Method: defaults +# Create a "defaults" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag +# +# Note: this button has a special meaning to the initialization script, +# and tells it to ERASE the current query string so that your defaults +# are used again! +#### +'defaults' => <<'END_OF_FUNC', +sub defaults { + my($self,@p) = self_or_default(@_); + + my($label,@other) = $self->rearrange([[NAME,VALUE]],@p); + + $label=$self->escapeHTML($label); + $label = $label || "Defaults"; + my($value) = qq/ VALUE="$label"/; + my($other) = @other ? " @other" : ''; + return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/; +} +END_OF_FUNC + + +#### Method: checkbox +# Create a checkbox that is not logically linked to any others. +# The field value is "on" when the button is checked. +# Parameters: +# $name -> Name of the checkbox +# $checked -> (optional) turned on by default if true +# $value -> (optional) value of the checkbox, 'on' by default +# $label -> (optional) a user-readable label printed next to the box. +# Otherwise the checkbox name is used. +# Returns: +# A string containing a <INPUT TYPE="checkbox"> field +#### +'checkbox' => <<'END_OF_FUNC', +sub checkbox { + my($self,@p) = self_or_default(@_); + + my($name,$checked,$value,$label,$override,@other) = + $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p); + + if (!$override && defined($self->param($name))) { + $value = $self->param($name) unless defined $value; + $checked = $self->param($name) eq $value ? ' CHECKED' : ''; + } else { + $checked = $checked ? ' CHECKED' : ''; + $value = defined $value ? $value : 'on'; + } + my($the_label) = defined $label ? $label : $name; + $name = $self->escapeHTML($name); + $value = $self->escapeHTML($value); + $the_label = $self->escapeHTML($the_label); + my($other) = @other ? " @other" : ''; + $self->register_parameter($name); + return <<END; +<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label +END +} +END_OF_FUNC + + +#### Method: checkbox_group +# Create a list of logically-linked checkboxes. +# Parameters: +# $name -> Common name for all the check boxes +# $values -> A pointer to a regular array containing the +# values for each checkbox in the group. +# $defaults -> (optional) +# 1. If a pointer to a regular array of checkbox values, +# then this will be used to decide which +# checkboxes to turn on by default. +# 2. If a scalar, will be assumed to hold the +# value of a single checkbox in the group to turn on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to an associative array of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of <INPUT TYPE="checkbox"> fields +#### +'checkbox_group' => <<'END_OF_FUNC', +sub checkbox_group { + my($self,@p) = self_or_default(@_); + + my($name,$values,$defaults,$linebreak,$labels,$rows,$columns, + $rowheaders,$colheaders,$override,$nolabels,@other) = + $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + LINEBREAK,LABELS,ROWS,[COLUMNS,COLS], + ROWHEADERS,COLHEADERS, + [OVERRIDE,FORCE],NOLABELS],@p); + + my($checked,$break,$result,$label); + + my(%checked) = $self->previous_or_default($name,$defaults,$override); + + $break = $linebreak ? "<BR>" : ''; + $name=$self->escapeHTML($name); + + # Create the elements + my(@elements); + my(@values) = $values ? @$values : $self->param($name); + my($other) = @other ? " @other" : ''; + foreach (@values) { + $checked = $checked{$_} ? ' CHECKED' : ''; + $label = ''; + unless (defined($nolabels) && $nolabels) { + $label = $_; + $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label = $self->escapeHTML($label); + } + $_ = $self->escapeHTML($_); + push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label} ${break}/); + } + $self->register_parameter($name); + return wantarray ? @elements : join('',@elements) unless $columns; + return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); +} +END_OF_FUNC + + +# Escape HTML -- used internally +'escapeHTML' => <<'END_OF_FUNC', +sub escapeHTML { + my($self,$toencode) = @_; + return undef unless defined($toencode); + return $toencode if $self->{'dontescape'}; + $toencode=~s/&/&/g; + $toencode=~s/\"/"/g; + $toencode=~s/>/>/g; + $toencode=~s/</</g; + return $toencode; +} +END_OF_FUNC + + +# Internal procedure - don't use +'_tableize' => <<'END_OF_FUNC', +sub _tableize { + my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; + my($result); + + $rows = int(0.99 + @elements/$columns) unless $rows; + # rearrange into a pretty table + $result = "<TABLE>"; + my($row,$column); + unshift(@$colheaders,'') if @$colheaders && @$rowheaders; + $result .= "<TR>" if @{$colheaders}; + foreach (@{$colheaders}) { + $result .= "<TH>$_</TH>"; + } + for ($row=0;$row<$rows;$row++) { + $result .= "<TR>"; + $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders; + for ($column=0;$column<$columns;$column++) { + $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"; + } + $result .= "</TR>"; + } + $result .= "</TABLE>"; + return $result; +} +END_OF_FUNC + + +#### Method: radio_group +# Create a list of logically-linked radio buttons. +# Parameters: +# $name -> Common name for all the buttons. +# $values -> A pointer to a regular array containing the +# values for each button in the group. +# $default -> (optional) Value of the button to turn on by default. Pass '-' +# to turn _nothing_ on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to an associative array of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of <INPUT TYPE="radio"> fields +#### +'radio_group' => <<'END_OF_FUNC', +sub radio_group { + my($self,@p) = self_or_default(@_); + + my($name,$values,$default,$linebreak,$labels, + $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) = + $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS, + ROWS,[COLUMNS,COLS], + ROWHEADERS,COLHEADERS, + [OVERRIDE,FORCE],NOLABELS],@p); + my($result,$checked); + + if (!$override && defined($self->param($name))) { + $checked = $self->param($name); + } else { + $checked = $default; + } + # If no check array is specified, check the first by default + $checked = $values->[0] unless $checked; + $name=$self->escapeHTML($name); + + my(@elements); + my(@values) = $values ? @$values : $self->param($name); + my($other) = @other ? " @other" : ''; + foreach (@values) { + my($checkit) = $checked eq $_ ? ' CHECKED' : ''; + my($break) = $linebreak ? '<BR>' : ''; + my($label)=''; + unless (defined($nolabels) && $nolabels) { + $label = $_; + $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label = $self->escapeHTML($label); + } + $_=$self->escapeHTML($_); + push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label} ${break}/); + } + $self->register_parameter($name); + return wantarray ? @elements : join('',@elements) unless $columns; + return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); +} +END_OF_FUNC + + +#### Method: popup_menu +# Create a popup menu. +# Parameters: +# $name -> Name for all the menu +# $values -> A pointer to a regular array containing the +# text of each menu item. +# $default -> (optional) Default item to display +# $labels -> (optional) +# A pointer to an associative array of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a popup menu. +#### +'popup_menu' => <<'END_OF_FUNC', +sub popup_menu { + my($self,@p) = self_or_default(@_); + + my($name,$values,$default,$labels,$override,@other) = + $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p); + my($result,$selected); + + if (!$override && defined($self->param($name))) { + $selected = $self->param($name); + } else { + $selected = $default; + } + $name=$self->escapeHTML($name); + my($other) = @other ? " @other" : ''; + + my(@values) = $values ? @$values : $self->param($name); + $result = qq/<SELECT NAME="$name"$other>\n/; + foreach (@values) { + my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : ''; + my($label) = $_; + $label = $labels->{$_} if defined($labels) && $labels->{$_}; + my($value) = $self->escapeHTML($_); + $label=$self->escapeHTML($label); + $result .= "<OPTION $selectit VALUE=\"$value\">$label\n"; + } + + $result .= "</SELECT>\n"; + return $result; +} +END_OF_FUNC + + +#### Method: scrolling_list +# Create a scrolling list. +# Parameters: +# $name -> name for the list +# $values -> A pointer to a regular array containing the +# values for each option line in the list. +# $defaults -> (optional) +# 1. If a pointer to a regular array of options, +# then this will be used to decide which +# lines to turn on by default. +# 2. Otherwise holds the value of the single line to turn on. +# $size -> (optional) Size of the list. +# $multiple -> (optional) If set, allow multiple selections. +# $labels -> (optional) +# A pointer to an associative array of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a scrolling list. +#### +'scrolling_list' => <<'END_OF_FUNC', +sub scrolling_list { + my($self,@p) = self_or_default(@_); + my($name,$values,$defaults,$size,$multiple,$labels,$override,@other) + = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p); + + my($result); + my(@values) = $values ? @$values : $self->param($name); + $size = $size || scalar(@values); + + my(%selected) = $self->previous_or_default($name,$defaults,$override); + my($is_multiple) = $multiple ? ' MULTIPLE' : ''; + my($has_size) = $size ? " SIZE=$size" : ''; + my($other) = @other ? " @other" : ''; + + $name=$self->escapeHTML($name); + $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/; + foreach (@values) { + my($selectit) = $selected{$_} ? 'SELECTED' : ''; + my($label) = $_; + $label = $labels->{$_} if defined($labels) && $labels->{$_}; + $label=$self->escapeHTML($label); + my($value)=$self->escapeHTML($_); + $result .= "<OPTION $selectit VALUE=\"$value\">$label\n"; + } + $result .= "</SELECT>\n"; + $self->register_parameter($name); + return $result; +} +END_OF_FUNC + + +#### Method: hidden +# Parameters: +# $name -> Name of the hidden field +# @default -> (optional) Initial values of field (may be an array) +# or +# $default->[initial values of field] +# Returns: +# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value"> +#### +'hidden' => <<'END_OF_FUNC', +sub hidden { + my($self,@p) = self_or_default(@_); + + # this is the one place where we departed from our standard + # calling scheme, so we have to special-case (darn) + my(@result,@value); + my($name,$default,$override,@other) = + $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); + + my $do_override = 0; + if ( substr($p[0],0,1) eq '-' || $self->use_named_parameters ) { + @value = ref($default) ? @{$default} : $default; + $do_override = $override; + } else { + foreach ($default,$override,@other) { + push(@value,$_) if defined($_); + } + } + + # use previous values if override is not set + my @prev = $self->param($name); + @value = @prev if !$do_override && @prev; + + $name=$self->escapeHTML($name); + foreach (@value) { + $_=$self->escapeHTML($_); + push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/); + } + return wantarray ? @result : join('',@result); +} +END_OF_FUNC + + +#### Method: image_button +# Parameters: +# $name -> Name of the button +# $src -> URL of the image source +# $align -> Alignment style (TOP, BOTTOM or MIDDLE) +# Returns: +# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment"> +#### +'image_button' => <<'END_OF_FUNC', +sub image_button { + my($self,@p) = self_or_default(@_); + + my($name,$src,$alignment,@other) = + $self->rearrange([NAME,SRC,ALIGN],@p); + + my($align) = $alignment ? " ALIGN=\U$alignment" : ''; + my($other) = @other ? " @other" : ''; + $name=$self->escapeHTML($name); + return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/; +} +END_OF_FUNC + + +#### Method: self_url +# Returns a URL containing the current script and all its +# param/value pairs arranged as a query. You can use this +# to create a link that, when selected, will reinvoke the +# script with all its state information preserved. +#### +'self_url' => <<'END_OF_FUNC', +sub self_url { + my($self) = self_or_default(@_); + my($query_string) = $self->query_string; + my $protocol = $self->protocol(); + my $name = "$protocol://" . $self->server_name; + $name .= ":" . $self->server_port + unless $self->server_port == 80; + $name .= $self->script_name; + $name .= $self->path_info if $self->path_info; + return $name unless $query_string; + return "$name?$query_string"; +} +END_OF_FUNC + + +# This is provided as a synonym to self_url() for people unfortunate +# enough to have incorporated it into their programs already! +'state' => <<'END_OF_FUNC', +sub state { + &self_url; +} +END_OF_FUNC + + +#### Method: url +# Like self_url, but doesn't return the query string part of +# the URL. +#### +'url' => <<'END_OF_FUNC', +sub url { + my($self) = self_or_default(@_); + my $protocol = $self->protocol(); + my $name = "$protocol://" . $self->server_name; + $name .= ":" . $self->server_port + unless $self->server_port == 80; + $name .= $self->script_name; + return $name; +} + +END_OF_FUNC + +#### Method: cookie +# Set or read a cookie from the specified name. +# Cookie can then be passed to header(). +# Usual rules apply to the stickiness of -value. +# Parameters: +# -name -> name for this cookie (optional) +# -value -> value of this cookie (scalar, array or hash) +# -path -> paths for which this cookie is valid (optional) +# -domain -> internet domain in which this cookie is valid (optional) +# -secure -> if true, cookie only passed through secure channel (optional) +# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) +#### +'cookie' => <<'END_OF_FUNC', +# temporary, for debugging. +sub cookie { + my($self,@p) = self_or_default(@_); + my($name,$value,$path,$domain,$secure,$expires) = + $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p); + + + # if no value is supplied, then we retrieve the + # value of the cookie, if any. For efficiency, we cache the parsed + # cookie in our state variables. + unless (defined($value)) { + unless ($self->{'.cookies'}) { + my(@pairs) = split("; ",$self->raw_cookie); + foreach (@pairs) { + my($key,$value) = split("="); + my(@values) = map unescape($_),split('&',$value); + $self->{'.cookies'}->{unescape($key)} = [@values]; + } + } + + # If no name is supplied, then retrieve the names of all our cookies. + return () unless $self->{'.cookies'}; + return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0] + if defined($name) && $name ne ''; + return keys %{$self->{'.cookies'}}; + } + my(@values); + + # Pull out our parameters. + if (ref($value)) { + if (ref($value) eq 'ARRAY') { + @values = @$value; + } elsif (ref($value) eq 'HASH') { + @values = %$value; + } + } else { + @values = ($value); + } + @values = map escape($_),@values; + + # I.E. requires the path to be present. + ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path; + + my(@constant_values); + push(@constant_values,"domain=$domain") if $domain; + push(@constant_values,"path=$path") if $path; + push(@constant_values,"expires=".&date(&expire_calc($expires),'cookie')) + if $expires; + push(@constant_values,'secure') if $secure; + + my($key) = &escape($name); + my($cookie) = join("=",$key,join("&",@values)); + return join("; ",$cookie,@constant_values); +} +END_OF_FUNC + + +# This internal routine creates an expires time exactly some number of +# hours from the current time. It incorporates modifications from +# Fisher Mark. +'expire_calc' => <<'END_OF_FUNC', +sub expire_calc { + my($time) = @_; + my(%mult) = ('s'=>1, + 'm'=>60, + 'h'=>60*60, + 'd'=>60*60*24, + 'M'=>60*60*24*30, + 'y'=>60*60*24*365); + # format for time can be in any of the forms... + # "now" -- expire immediately + # "+180s" -- in 180 seconds + # "+2m" -- in 2 minutes + # "+12h" -- in 12 hours + # "+1d" -- in 1 day + # "+3M" -- in 3 months + # "+2y" -- in 2 years + # "-3m" -- 3 minutes ago(!) + # If you don't supply one of these forms, we assume you are + # specifying the date yourself + my($offset); + if (!$time || ($time eq 'now')) { + $offset = 0; + } elsif ($time=~/^([+-]?\d+)([mhdMy]?)/) { + $offset = ($mult{$2} || 1)*$1; + } else { + return $time; + } + return (time+$offset); +} +END_OF_FUNC + +# This internal routine creates date strings suitable for use in +# cookies and HTTP headers. (They differ, unfortunately.) +# Thanks to Fisher Mark for this. +'date' => <<'END_OF_FUNC', +sub date { + my($time,$format) = @_; + my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; + my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; + + # pass through preformatted dates for the sake of expire_calc() + if ("$time" =~ m/^[^0-9]/o) { + return $time; + } + + # make HTTP/cookie date string from GMT'ed time + # (cookies use '-' as date separator, HTTP uses ' ') + my($sc) = ' '; + $sc = '-' if $format eq "cookie"; + my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); + $year += 1900; + return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", + $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); +} +END_OF_FUNC + +############################################### +# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT +############################################### + +#### Method: path_info +# Return the extra virtual path information provided +# after the URL (if any) +#### +'path_info' => <<'END_OF_FUNC', +sub path_info { + return $ENV{'PATH_INFO'}; +} +END_OF_FUNC + + +#### Method: request_method +# Returns 'POST', 'GET', 'PUT' or 'HEAD' +#### +'request_method' => <<'END_OF_FUNC', +sub request_method { + return $ENV{'REQUEST_METHOD'}; +} +END_OF_FUNC + +#### Method: path_translated +# Return the physical path information provided +# by the URL (if any) +#### +'path_translated' => <<'END_OF_FUNC', +sub path_translated { + return $ENV{'PATH_TRANSLATED'}; +} +END_OF_FUNC + + +#### Method: query_string +# Synthesize a query string from our current +# parameters +#### +'query_string' => <<'END_OF_FUNC', +sub query_string { + my($self) = self_or_default(@_); + my($param,$value,@pairs); + foreach $param ($self->param) { + my($eparam) = &escape($param); + foreach $value ($self->param($param)) { + $value = &escape($value); + push(@pairs,"$eparam=$value"); + } + } + return join("&",@pairs); +} +END_OF_FUNC + + +#### Method: accept +# Without parameters, returns an array of the +# MIME types the browser accepts. +# With a single parameter equal to a MIME +# type, will return undef if the browser won't +# accept it, 1 if the browser accepts it but +# doesn't give a preference, or a floating point +# value between 0.0 and 1.0 if the browser +# declares a quantitative score for it. +# This handles MIME type globs correctly. +#### +'accept' => <<'END_OF_FUNC', +sub accept { + my($self,$search) = self_or_CGI(@_); + my(%prefs,$type,$pref,$pat); + + my(@accept) = split(',',$self->http('accept')); + + foreach (@accept) { + ($pref) = /q=(\d\.\d+|\d+)/; + ($type) = m#(\S+/[^;]+)#; + next unless $type; + $prefs{$type}=$pref || 1; + } + + return keys %prefs unless $search; + + # if a search type is provided, we may need to + # perform a pattern matching operation. + # The MIME types use a glob mechanism, which + # is easily translated into a perl pattern match + + # First return the preference for directly supported + # types: + return $prefs{$search} if $prefs{$search}; + + # Didn't get it, so try pattern matching. + foreach (keys %prefs) { + next unless /\*/; # not a pattern match + ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters + $pat =~ s/\*/.*/g; # turn it into a pattern + return $prefs{$_} if $search=~/$pat/; + } +} +END_OF_FUNC + + +#### Method: user_agent +# If called with no parameters, returns the user agent. +# If called with one parameter, does a pattern match (case +# insensitive) on the user agent. +#### +'user_agent' => <<'END_OF_FUNC', +sub user_agent { + my($self,$match)=self_or_CGI(@_); + return $self->http('user_agent') unless $match; + return $self->http('user_agent') =~ /$match/i; +} +END_OF_FUNC + + +#### Method: cookie +# Returns the magic cookie for the session. +# To set the magic cookie for new transations, +# try print $q->header('-Set-cookie'=>'my cookie') +#### +'raw_cookie' => <<'END_OF_FUNC', +sub raw_cookie { + my($self) = self_or_CGI(@_); + return $self->http('cookie') || $ENV{'COOKIE'} || ''; +} +END_OF_FUNC + +#### Method: virtual_host +# Return the name of the virtual_host, which +# is not always the same as the server +###### +'virtual_host' => <<'END_OF_FUNC', +sub virtual_host { + return http('host') || server_name(); +} +END_OF_FUNC + +#### Method: remote_host +# Return the name of the remote host, or its IP +# address if unavailable. If this variable isn't +# defined, it returns "localhost" for debugging +# purposes. +#### +'remote_host' => <<'END_OF_FUNC', +sub remote_host { + return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} + || 'localhost'; +} +END_OF_FUNC + + +#### Method: remote_addr +# Return the IP addr of the remote host. +#### +'remote_addr' => <<'END_OF_FUNC', +sub remote_addr { + return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; +} +END_OF_FUNC + + +#### Method: script_name +# Return the partial URL to this script for +# self-referencing scripts. Also see +# self_url(), which returns a URL with all state information +# preserved. +#### +'script_name' => <<'END_OF_FUNC', +sub script_name { + return $ENV{'SCRIPT_NAME'} if $ENV{'SCRIPT_NAME'}; + # These are for debugging + return "/$0" unless $0=~/^\//; + return $0; +} +END_OF_FUNC + + +#### Method: referer +# Return the HTTP_REFERER: useful for generating +# a GO BACK button. +#### +'referer' => <<'END_OF_FUNC', +sub referer { + my($self) = self_or_CGI(@_); + return $self->http('referer'); +} +END_OF_FUNC + + +#### Method: server_name +# Return the name of the server +#### +'server_name' => <<'END_OF_FUNC', +sub server_name { + return $ENV{'SERVER_NAME'} || 'localhost'; +} +END_OF_FUNC + +#### Method: server_software +# Return the name of the server software +#### +'server_software' => <<'END_OF_FUNC', +sub server_software { + return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; +} +END_OF_FUNC + +#### Method: server_port +# Return the tcp/ip port the server is running on +#### +'server_port' => <<'END_OF_FUNC', +sub server_port { + return $ENV{'SERVER_PORT'} || 80; # for debugging +} +END_OF_FUNC + +#### Method: server_protocol +# Return the protocol (usually HTTP/1.0) +#### +'server_protocol' => <<'END_OF_FUNC', +sub server_protocol { + return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging +} +END_OF_FUNC + +#### Method: http +# Return the value of an HTTP variable, or +# the list of variables if none provided +#### +'http' => <<'END_OF_FUNC', +sub http { + my ($self,$parameter) = self_or_CGI(@_); + return $ENV{$parameter} if $parameter=~/^HTTP/; + return $ENV{"HTTP_\U$parameter\E"} if $parameter; + my(@p); + foreach (keys %ENV) { + push(@p,$_) if /^HTTP/; + } + return @p; +} +END_OF_FUNC + +#### Method: https +# Return the value of HTTPS +#### +'https' => <<'END_OF_FUNC', +sub https { + local($^W)=0; + my ($self,$parameter) = self_or_CGI(@_); + return $ENV{HTTPS} unless $parameter; + return $ENV{$parameter} if $parameter=~/^HTTPS/; + return $ENV{"HTTPS_\U$parameter\E"} if $parameter; + my(@p); + foreach (keys %ENV) { + push(@p,$_) if /^HTTPS/; + } + return @p; +} +END_OF_FUNC + +#### Method: protocol +# Return the protocol (http or https currently) +#### +'protocol' => <<'END_OF_FUNC', +sub protocol { + local($^W)=0; + my $self = shift; + return 'https' if $self->https() eq 'ON'; + return 'https' if $self->server_port == 443; + my $prot = $self->server_protocol; + my($protocol,$version) = split('/',$prot); + return "\L$protocol\E"; +} +END_OF_FUNC + +#### Method: remote_ident +# Return the identity of the remote user +# (but only if his host is running identd) +#### +'remote_ident' => <<'END_OF_FUNC', +sub remote_ident { + return $ENV{'REMOTE_IDENT'}; +} +END_OF_FUNC + + +#### Method: auth_type +# Return the type of use verification/authorization in use, if any. +#### +'auth_type' => <<'END_OF_FUNC', +sub auth_type { + return $ENV{'AUTH_TYPE'}; +} +END_OF_FUNC + + +#### Method: remote_user +# Return the authorization name used for user +# verification. +#### +'remote_user' => <<'END_OF_FUNC', +sub remote_user { + return $ENV{'REMOTE_USER'}; +} +END_OF_FUNC + + +#### Method: user_name +# Try to return the remote user's name by hook or by +# crook +#### +'user_name' => <<'END_OF_FUNC', +sub user_name { + my ($self) = self_or_CGI(@_); + return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; +} +END_OF_FUNC + +#### Method: nph +# Set or return the NPH global flag +#### +'nph' => <<'END_OF_FUNC', +sub nph { + my ($self,$param) = self_or_CGI(@_); + $CGI::NPH = $param if defined($param); + return $CGI::NPH; +} +END_OF_FUNC + +#### Method: private_tempfiles +# Set or return the private_tempfiles global flag +#### +'private_tempfiles' => <<'END_OF_FUNC', +sub private_tempfiles { + my ($self,$param) = self_or_CGI(@_); + $CGI::$PRIVATE_TEMPFILES = $param if defined($param); + return $CGI::PRIVATE_TEMPFILES; +} +END_OF_FUNC + +# -------------- really private subroutines ----------------- +'previous_or_default' => <<'END_OF_FUNC', +sub previous_or_default { + my($self,$name,$defaults,$override) = @_; + my(%selected); + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined($self->param($name)) ) ) { + grep($selected{$_}++,$self->param($name)); + } elsif (defined($defaults) && ref($defaults) && + (ref($defaults) eq 'ARRAY')) { + grep($selected{$_}++,@{$defaults}); + } else { + $selected{$defaults}++ if defined($defaults); + } + + return %selected; +} +END_OF_FUNC + +'register_parameter' => <<'END_OF_FUNC', +sub register_parameter { + my($self,$param) = @_; + $self->{'.parametersToAdd'}->{$param}++; +} +END_OF_FUNC + +'get_fields' => <<'END_OF_FUNC', +sub get_fields { + my($self) = @_; + return $self->hidden('-name'=>'.cgifields', + '-values'=>[keys %{$self->{'.parametersToAdd'}}], + '-override'=>1); +} +END_OF_FUNC + +'read_from_cmdline' => <<'END_OF_FUNC', +sub read_from_cmdline { + require "shellwords.pl"; + my($input,@words); + my($query_string); + if (@ARGV) { + $input = join(" ",@ARGV); + } else { + print STDERR "(offline mode: enter name=value pairs on standard input)\n"; + chomp(@lines = <>); # remove newlines + $input = join(" ",@lines); + } + + # minimal handling of escape characters + $input=~s/\\=/%3D/g; + $input=~s/\\&/%26/g; + + @words = &shellwords($input); + if ("@words"=~/=/) { + $query_string = join('&',@words); + } else { + $query_string = join('+',@words); + } + return $query_string; +} +END_OF_FUNC + +##### +# subroutine: read_multipart +# +# Read multipart data and store it into our parameters. +# An interesting feature is that if any of the parts is a file, we +# create a temporary file and open up a filehandle on it so that the +# caller can read from it if necessary. +##### +'read_multipart' => <<'END_OF_FUNC', +sub read_multipart { + my($self,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + while (!$buffer->eof) { + %header = $buffer->readHeader; + die "Malformed multipart POST\n" unless %header; + + # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition" + # Sheesh. + my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition'; + my($param)= $header{$key}=~/ name="([^\"]*)"/; + + # possible bug: our regular expression expects the filename= part to fall + # at the end of the line. Netscape doesn't escape quotation marks in file names!!! + my($filename) = $header{$key}=~/ filename="(.*)"$/; + + # add this parameter to our list + $self->add_parameter($param); + + # If no filename specified, then just read the data and assign it + # to our parameter list. + unless ($filename) { + my($value) = $buffer->readBody; + push(@{$self->{$param}},$value); + next; + } + + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + my($tmpfile) = new TempFile; + my $tmp = $tmpfile->as_string; + + # Now create a new filehandle in the caller's namespace. + # The name of this filehandle just happens to be identical + # to the original filename (NOT the name of the temporary + # file, which is hidden!) + my($filehandle); + if ($filename=~/^[a-zA-Z_]/) { + my($frame,$cp)=(1); + do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()"); + $filehandle = "$cp\:\:$filename"; + } else { + $filehandle = "\:\:$filename"; + } + + # potential security problem -- this type of line can clobber + # tempfile, and can be abused by malicious users. + # open ($filehandle,">$tmp") || die "CGI open of $tmpfile: $!\n"; + + # This technique causes open to fail if file already exists. + unless (defined(&O_RDWR)) { + require Fcntl; + import Fcntl qw/O_RDWR O_CREAT O_EXCL/; + } + sysopen($filehandle,$tmp,&O_RDWR|&O_CREAT|&O_EXCL) || die "CGI open of $tmp: $!\n"; + unlink($tmp) if $PRIVATE_TEMPFILES; + + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + chmod 0600,$tmp; # only the owner can tamper with it + my $data; + while (defined($data = $buffer->read)) { + print $filehandle $data; + } + + seek($filehandle,0,0); #rewind file + push(@{$self->{$param}},$filename); + + # Under Unix, it would be safe to let the temporary file + # be deleted immediately. However, I fear that other operating + # systems are not so forgiving. Therefore we save a reference + # to the temporary file in the CGI object so that the file + # isn't unlinked until the CGI object itself goes out of + # scope. This is a bit hacky, but it has the interesting side + # effect that one can access the name of the tmpfile by + # asking for $query->{$query->param('foo')}, where 'foo' + # is the name of the file upload field. + $self->{'.tmpfiles'}->{$filename}= { + name=>($PRIVATE_TEMPFILES ? '' : $tmpfile), + info=>{%header} + } + } +} +END_OF_FUNC + +'tmpFileName' => <<'END_OF_FUNC', +sub tmpFileName { + my($self,$filename) = self_or_default(@_); + return $self->{'.tmpfiles'}->{$filename}->{name} ? + $self->{'.tmpfiles'}->{$filename}->{name}->as_string + : ''; +} +END_OF_FUNC + +'uploadInfo' => <<'END_OF_FUNC' +sub uploadInfo { + my($self,$filename) = self_or_default(@_); + return $self->{'.tmpfiles'}->{$filename}->{info}; +} +END_OF_FUNC + +); +END_OF_AUTOLOAD +; + +# Globals and stubs for other packages that we use +package MultipartBuffer; + +# how many bytes to read at a time. We use +# a 5K buffer by default. +$FILLUNIT = 1024 * 5; +$TIMEOUT = 10*60; # 10 minute timeout +$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers +$CRLF=$CGI::CRLF; + +#reuse the autoload function +*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD; + +############################################################################### +################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### +############################################################################### +$AUTOLOADED_ROUTINES = ''; # prevent -w error +$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; +%SUBS = ( + +'new' => <<'END_OF_FUNC', +sub new { + my($package,$interface,$boundary,$length,$filehandle) = @_; + my $IN; + if ($filehandle) { + my($package) = caller; + # force into caller's package if necessary + $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle"; + } + $IN = "main::STDIN" unless $IN; + + $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode; + + # If the user types garbage into the file upload field, + # then Netscape passes NOTHING to the server (not good). + # We may hang on this read in that case. So we implement + # a read timeout. If nothing is ready to read + # by then, we return. + + # Netscape seems to be a little bit unreliable + # about providing boundary strings. + if ($boundary) { + + # Under the MIME spec, the boundary consists of the + # characters "--" PLUS the Boundary string + $boundary = "--$boundary"; + # Read the topmost (boundary) line plus the CRLF + my($null) = ''; + $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0); + } else { # otherwise we find it ourselves + my($old); + ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line + $boundary = <$IN>; # BUG: This won't work correctly under mod_perl + $length -= length($boundary); + chomp($boundary); # remove the CRLF + $/ = $old; # restore old line separator + } + + my $self = {LENGTH=>$length, + BOUNDARY=>$boundary, + IN=>$IN, + INTERFACE=>$interface, + BUFFER=>'', + }; + + $FILLUNIT = length($boundary) + if length($boundary) > $FILLUNIT; + + return bless $self,ref $package || $package; +} +END_OF_FUNC + +'readHeader' => <<'END_OF_FUNC', +sub readHeader { + my($self) = @_; + my($end); + my($ok) = 0; + my($bad) = 0; + do { + $self->fillBuffer($FILLUNIT); + $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; + $ok++ if $self->{BUFFER} eq ''; + $bad++ if !$ok && $self->{LENGTH} <= 0; + $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; + } until $ok || $bad; + return () if $bad; + + my($header) = substr($self->{BUFFER},0,$end+2); + substr($self->{BUFFER},0,$end+4) = ''; + my %return; + while ($header=~/^([\w-]+): (.*)$CRLF/mog) { + $return{$1}=$2; + } + return %return; +} +END_OF_FUNC + +# This reads and returns the body as a single scalar value. +'readBody' => <<'END_OF_FUNC', +sub readBody { + my($self) = @_; + my($data); + my($returnval)=''; + while (defined($data = $self->read)) { + $returnval .= $data; + } + return $returnval; +} +END_OF_FUNC + +# This will read $bytes or until the boundary is hit, whichever happens +# first. After the boundary is hit, we return undef. The next read will +# skip over the boundary and begin reading again; +'read' => <<'END_OF_FUNC', +sub read { + my($self,$bytes) = @_; + + # default number of bytes to read + $bytes = $bytes || $FILLUNIT; + + # Fill up our internal buffer in such a way that the boundary + # is never split between reads. + $self->fillBuffer($bytes); + + # Find the boundary in the buffer (it may not be there). + my $start = index($self->{BUFFER},$self->{BOUNDARY}); + # protect against malformed multipart POST operations + die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0); + + # If the boundary begins the data, then skip past it + # and return undef. The +2 here is a fiendish plot to + # remove the CR/LF pair at the end of the boundary. + if ($start == 0) { + + # clear us out completely if we've hit the last boundary. + if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) { + $self->{BUFFER}=''; + $self->{LENGTH}=0; + return undef; + } + + # just remove the boundary. + substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)=''; + return undef; + } + + my $bytesToReturn; + if ($start > 0) { # read up to the boundary + $bytesToReturn = $start > $bytes ? $bytes : $start; + } else { # read the requested number of bytes + # leave enough bytes in the buffer to allow us to read + # the boundary. Thanks to Kevin Hendrick for finding + # this one. + $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1); + } + + my $returnval=substr($self->{BUFFER},0,$bytesToReturn); + substr($self->{BUFFER},0,$bytesToReturn)=''; + + # If we hit the boundary, remove the CRLF from the end. + return ($start > 0) ? substr($returnval,0,-2) : $returnval; +} +END_OF_FUNC + + +# This fills up our internal buffer in such a way that the +# boundary is never split between reads +'fillBuffer' => <<'END_OF_FUNC', +sub fillBuffer { + my($self,$bytes) = @_; + return unless $self->{LENGTH}; + + my($boundaryLength) = length($self->{BOUNDARY}); + my($bufferLength) = length($self->{BUFFER}); + my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; + $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead; + + # Try to read some data. We may hang here if the browser is screwed up. + my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN}, + \$self->{BUFFER}, + $bytesToRead, + $bufferLength); + + # An apparent bug in the Apache server causes the read() + # to return zero bytes repeatedly without blocking if the + # remote user aborts during a file transfer. I don't know how + # they manage this, but the workaround is to abort if we get + # more than SPIN_LOOP_MAX consecutive zero reads. + if ($bytesRead == 0) { + die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" + if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); + } else { + $self->{ZERO_LOOP_COUNTER}=0; + } + + $self->{LENGTH} -= $bytesRead; +} +END_OF_FUNC + + +# Return true when we've finished reading +'eof' => <<'END_OF_FUNC' +sub eof { + my($self) = @_; + return 1 if (length($self->{BUFFER}) == 0) + && ($self->{LENGTH} <= 0); + undef; +} +END_OF_FUNC + +); +END_OF_AUTOLOAD + +#################################################################################### +################################## TEMPORARY FILES ################################# +#################################################################################### +package TempFile; + +$SL = $CGI::SL; +unless ($TMPDIRECTORY) { + @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items"); + foreach (@TEMP) { + do {$TMPDIRECTORY = $_; last} if -d $_ && -w _; + } +} + +$TMPDIRECTORY = "." unless $TMPDIRECTORY; +$SEQUENCE="CGItemp${$}0000"; + +# cute feature, but overload implementation broke it +# %OVERLOAD = ('""'=>'as_string'); +*TempFile::AUTOLOAD = \&CGI::AUTOLOAD; + +############################################################################### +################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND #################### +############################################################################### +$AUTOLOADED_ROUTINES = ''; # prevent -w error +$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD'; +%SUBS = ( + +'new' => <<'END_OF_FUNC', +sub new { + my($package) = @_; + $SEQUENCE++; + my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}"; + return bless \$directory; +} +END_OF_FUNC + +'DESTROY' => <<'END_OF_FUNC', +sub DESTROY { + my($self) = @_; + unlink $$self; # get rid of the file +} +END_OF_FUNC + +'as_string' => <<'END_OF_FUNC' +sub as_string { + my($self) = @_; + return $$self; +} +END_OF_FUNC + +); +END_OF_AUTOLOAD + +package CGI; + +# We get a whole bunch of warnings about "possibly uninitialized variables" +# when running with the -w switch. Touch them all once to get rid of the +# warnings. This is ugly and I hate it. +if ($^W) { + $CGI::CGI = ''; + $CGI::CGI=<<EOF; + $CGI::VERSION; + $MultipartBuffer::SPIN_LOOP_MAX; + $MultipartBuffer::CRLF; + $MultipartBuffer::TIMEOUT; + $MultipartBuffer::FILLUNIT; + $TempFile::SEQUENCE; +EOF + ; +} + +$revision; + +__END__ + +=head1 NAME + +CGI - Simple Common Gateway Interface Class + +=head1 SYNOPSIS + + use CGI; + # the rest is too complicated for a synopsis; keep reading + +=head1 ABSTRACT + +This perl library uses perl5 objects to make it easy to create +Web fill-out forms and parse their contents. This package +defines CGI objects, entities that contain the values of the +current query string and other state variables. +Using a CGI object's methods, you can examine keywords and parameters +passed to your script, and create forms whose initial values +are taken from the current query (thereby preserving state +information). + +The current version of CGI.pm is available at + + http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html + ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ + +=head1 INSTALLATION + +CGI is a part of the base Perl installation. However, you may need +to install a newer version someday. Therefore: + +To install this package, just change to the directory in which this +file is found and type the following: + + perl Makefile.PL + make + make install + +This will copy CGI.pm to your perl library directory for use by all +perl scripts. You probably must be root to do this. Now you can +load the CGI routines in your Perl scripts with the line: + + use CGI; + +If you don't have sufficient privileges to install CGI.pm in the Perl +library directory, you can put CGI.pm into some convenient spot, such +as your home directory, or in cgi-bin itself and prefix all Perl +scripts that call it with something along the lines of the following +preamble: + + use lib '/home/davis/lib'; + use CGI; + +If you are using a version of perl earlier than 5.002 (such as NT perl), use +this instead: + + BEGIN { + unshift(@INC,'/home/davis/lib'); + } + use CGI; + +The CGI distribution also comes with a cute module called L<CGI::Carp>. +It redefines the die(), warn(), confess() and croak() error routines +so that they write nicely formatted error messages into the server's +error log (or to the output stream of your choice). This avoids long +hours of groping through the error and access logs, trying to figure +out which CGI script is generating error messages. If you choose, +you can even have fatal error messages echoed to the browser to avoid +the annoying and uninformative "Server Error" message. + +=head1 DESCRIPTION + +=head2 CREATING A NEW QUERY OBJECT: + + $query = new CGI; + +This will parse the input (from both POST and GET methods) and store +it into a perl5 object called $query. + +=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE + + $query = new CGI(INPUTFILE); + +If you provide a file handle to the new() method, it +will read parameters from the file (or STDIN, or whatever). The +file can be in any of the forms describing below under debugging +(i.e. a series of newline delimited TAG=VALUE pairs will work). +Conveniently, this type of file is created by the save() method +(see below). Multiple records can be saved and restored. + +Perl purists will be pleased to know that this syntax accepts +references to file handles, or even references to filehandle globs, +which is the "official" way to pass a filehandle: + + $query = new CGI(\*STDIN); + +You can also initialize the query object from an associative array +reference: + + $query = new CGI( {'dinosaur'=>'barney', + 'song'=>'I love you', + 'friends'=>[qw/Jessica George Nancy/]} + ); + +or from a properly formatted, URL-escaped query string: + + $query = new CGI('dinosaur=barney&color=purple'); + +To create an empty query, initialize it from an empty string or hash: + + $empty_query = new CGI(""); + -or- + $empty_query = new CGI({}); + +=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY: + + @keywords = $query->keywords + +If the script was invoked as the result of an <ISINDEX> search, the +parsed keywords can be obtained as an array using the keywords() method. + +=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT: + + @names = $query->param + +If the script was invoked with a parameter list +(e.g. "name1=value1&name2=value2&name3=value3"), the param() +method will return the parameter names as a list. If the +script was invoked as an <ISINDEX> script, there will be a +single parameter named 'keywords'. + +NOTE: As of version 1.5, the array of parameter names returned will +be in the same order as they were submitted by the browser. +Usually this order is the same as the order in which the +parameters are defined in the form (however, this isn't part +of the spec, and so isn't guaranteed). + +=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER: + + @values = $query->param('foo'); + + -or- + + $value = $query->param('foo'); + +Pass the param() method a single argument to fetch the value of the +named parameter. If the parameter is multivalued (e.g. from multiple +selections in a scrolling list), you can ask to receive an array. Otherwise +the method will return a single value. + +=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER: + + $query->param('foo','an','array','of','values'); + +This sets the value for the named parameter 'foo' to an array of +values. This is one way to change the value of a field AFTER +the script has been invoked once before. (Another way is with +the -override parameter accepted by all methods that generate +form elements.) + +param() also recognizes a named parameter style of calling described +in more detail later: + + $query->param(-name=>'foo',-values=>['an','array','of','values']); + + -or- + + $query->param(-name=>'foo',-value=>'the value'); + +=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER: + + $query->append(-name=>;'foo',-values=>['yet','more','values']); + +This adds a value or list of values to the named parameter. The +values are appended to the end of the parameter if it already exists. +Otherwise the parameter is created. Note that this method only +recognizes the named argument calling syntax. + +=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE: + + $query->import_names('R'); + +This creates a series of variables in the 'R' namespace. For example, +$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear. +If no namespace is given, this method will assume 'Q'. +WARNING: don't import anything into 'main'; this is a major security +risk!!!! + +In older versions, this method was called B<import()>. As of version 2.20, +this name has been removed completely to avoid conflict with the built-in +Perl module B<import> operator. + +=head2 DELETING A PARAMETER COMPLETELY: + + $query->delete('foo'); + +This completely clears a parameter. It sometimes useful for +resetting parameters that you don't want passed down between +script invocations. + +=head2 DELETING ALL PARAMETERS: + +$query->delete_all(); + +This clears the CGI object completely. It might be useful to ensure +that all the defaults are taken when you create a fill-out form. + +=head2 SAVING THE STATE OF THE FORM TO A FILE: + + $query->save(FILEHANDLE) + +This will write the current state of the form to the provided +filehandle. You can read it back in by providing a filehandle +to the new() method. Note that the filehandle can be a file, a pipe, +or whatever! + +The format of the saved file is: + + NAME1=VALUE1 + NAME1=VALUE1' + NAME2=VALUE2 + NAME3=VALUE3 + = + +Both name and value are URL escaped. Multi-valued CGI parameters are +represented as repeated names. A session record is delimited by a +single = symbol. You can write out multiple records and read them +back in with several calls to B<new>. You can do this across several +sessions by opening the file in append mode, allowing you to create +primitive guest books, or to keep a history of users' queries. Here's +a short example of creating multiple session records: + + use CGI; + + open (OUT,">>test.out") || die; + $records = 5; + foreach (0..$records) { + my $q = new CGI; + $q->param(-name=>'counter',-value=>$_); + $q->save(OUT); + } + close OUT; + + # reopen for reading + open (IN,"test.out") || die; + while (!eof(IN)) { + my $q = new CGI(IN); + print $q->param('counter'),"\n"; + } + +The file format used for save/restore is identical to that used by the +Whitehead Genome Center's data exchange format "Boulderio", and can be +manipulated and even databased using Boulderio utilities. See + + http://www.genome.wi.mit.edu/genome_software/other/boulder.html + +for further details. + +=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION: + + $myself = $query->self_url; + print "<A HREF=$myself>I'm talking to myself.</A>"; + +self_url() will return a URL, that, when selected, will reinvoke +this script with all its state information intact. This is most +useful when you want to jump around within the document using +internal anchors but you don't want to disrupt the current contents +of the form(s). Something like this will do the trick. + + $myself = $query->self_url; + print "<A HREF=$myself#table1>See table 1</A>"; + print "<A HREF=$myself#table2>See table 2</A>"; + print "<A HREF=$myself#yourself>See for yourself</A>"; + +If you don't want to get the whole query string, call +the method url() to return just the URL for the script: + + $myself = $query->url; + print "<A HREF=$myself>No query string in this baby!</A>\n"; + +You can also retrieve the unprocessed query string with query_string(): + + $the_string = $query->query_string; + +=head2 COMPATIBILITY WITH CGI-LIB.PL + +To make it easier to port existing programs that use cgi-lib.pl +the compatibility routine "ReadParse" is provided. Porting is +simple: + +OLD VERSION + require "cgi-lib.pl"; + &ReadParse; + print "The value of the antique is $in{antique}.\n"; + +NEW VERSION + use CGI; + CGI::ReadParse + print "The value of the antique is $in{antique}.\n"; + +CGI.pm's ReadParse() routine creates a tied variable named %in, +which can be accessed to obtain the query variables. Like +ReadParse, you can also provide your own variable. Infrequently +used features of ReadParse, such as the creation of @in and $in +variables, are not supported. + +Once you use ReadParse, you can retrieve the query object itself +this way: + + $q = $in{CGI}; + print $q->textfield(-name=>'wow', + -value=>'does this really work?'); + +This allows you to start using the more interesting features +of CGI.pm without rewriting your old scripts from scratch. + +=head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS + +In versions of CGI.pm prior to 2.0, it could get difficult to remember +the proper order of arguments in CGI function calls that accepted five +or six different arguments. As of 2.0, there's a better way to pass +arguments to the various CGI functions. In this style, you pass a +series of name=>argument pairs, like this: + + $field = $query->radio_group(-name=>'OS', + -values=>[Unix,Windows,Macintosh], + -default=>'Unix'); + +The advantages of this style are that you don't have to remember the +exact order of the arguments, and if you leave out a parameter, in +most cases it will default to some reasonable value. If you provide +a parameter that the method doesn't recognize, it will usually do +something useful with it, such as incorporating it into the HTML form +tag. For example if Netscape decides next week to add a new +JUSTIFICATION parameter to the text field tags, you can start using +the feature without waiting for a new version of CGI.pm: + + $field = $query->textfield(-name=>'State', + -default=>'gaseous', + -justification=>'RIGHT'); + +This will result in an HTML tag that looks like this: + + <INPUT TYPE="textfield" NAME="State" VALUE="gaseous" + JUSTIFICATION="RIGHT"> + +Parameter names are case insensitive: you can use -name, or -Name or +-NAME. You don't have to use the hyphen if you don't want to. After +creating a CGI object, call the B<use_named_parameters()> method with +a nonzero value. This will tell CGI.pm that you intend to use named +parameters exclusively: + + $query = new CGI; + $query->use_named_parameters(1); + $field = $query->radio_group('name'=>'OS', + 'values'=>['Unix','Windows','Macintosh'], + 'default'=>'Unix'); + +Actually, CGI.pm only looks for a hyphen in the first parameter. So +you can leave it off subsequent parameters if you like. Something to +be wary of is the potential that a string constant like "values" will +collide with a keyword (and in fact it does!) While Perl usually +figures out when you're referring to a function and when you're +referring to a string, you probably should put quotation marks around +all string constants just to play it safe. + +=head2 CREATING THE HTTP HEADER: + + print $query->header; + + -or- + + print $query->header('image/gif'); + + -or- + + print $query->header('text/html','204 No response'); + + -or- + + print $query->header(-type=>'image/gif', + -nph=>1, + -status=>'402 Payment required', + -expires=>'+3d', + -cookie=>$cookie, + -Cost=>'$2.00'); + +header() returns the Content-type: header. You can provide your own +MIME type if you choose, otherwise it defaults to text/html. An +optional second parameter specifies the status code and a human-readable +message. For example, you can specify 204, "No response" to create a +script that tells the browser to do nothing at all. If you want to +add additional fields to the header, just tack them on to the end: + + print $query->header('text/html','200 OK','Content-Length: 3002'); + +The last example shows the named argument style for passing arguments +to the CGI methods using named parameters. Recognized parameters are +B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other +parameters will be stripped of their initial hyphens and turned into +header fields, allowing you to specify any HTTP header you desire. + +Most browsers will not cache the output from CGI scripts. Every time +the browser reloads the page, the script is invoked anew. You can +change this behavior with the B<-expires> parameter. When you specify +an absolute or relative expiration interval with this parameter, some +browsers and proxy servers will cache the script's output until the +indicated expiration date. The following forms are all valid for the +-expires field: + + +30s 30 seconds from now + +10m ten minutes from now + +1h one hour from now + -1d yesterday (i.e. "ASAP!") + now immediately + +3M in three months + +10y in ten years time + Thursday, 25-Apr-96 00:40:33 GMT at the indicated time & date + +(CGI::expires() is the static function call used internally that turns +relative time intervals into HTTP dates. You can call it directly if +you wish.) + +The B<-cookie> parameter generates a header that tells the browser to provide +a "magic cookie" during all subsequent transactions with your script. +Netscape cookies have a special format that includes interesting attributes +such as expiration time. Use the cookie() method to create and retrieve +session cookies. + +The B<-nph> parameter, if set to a true value, will issue the correct +headers to work with a NPH (no-parse-header) script. This is important +to use with certain servers, such as Microsoft Internet Explorer, which +expect all their scripts to be NPH. + +=head2 GENERATING A REDIRECTION INSTRUCTION + + print $query->redirect('http://somewhere.else/in/movie/land'); + +redirects the browser elsewhere. If you use redirection like this, +you should B<not> print out a header as well. As of version 2.0, we +produce both the unofficial Location: header and the official URI: +header. This should satisfy most servers and browsers. + +One hint I can offer is that relative links may not work correctly +when you generate a redirection to another document on your site. +This is due to a well-intentioned optimization that some servers use. +The solution to this is to use the full URL (including the http: part) +of the document you are redirecting to. + +You can use named parameters: + + print $query->redirect(-uri=>'http://somewhere.else/in/movie/land', + -nph=>1); + +The B<-nph> parameter, if set to a true value, will issue the correct +headers to work with a NPH (no-parse-header) script. This is important +to use with certain servers, such as Microsoft Internet Explorer, which +expect all their scripts to be NPH. + + +=head2 CREATING THE HTML HEADER: + + print $query->start_html(-title=>'Secrets of the Pyramids', + -author=>'fred@capricorn.org', + -base=>'true', + -target=>'_blank', + -meta=>{'keywords'=>'pharaoh secret mummy', + 'copyright'=>'copyright 1996 King Tut'}, + -style=>{'src'=>'/styles/style1.css'}, + -BGCOLOR=>'blue'); + + -or- + + print $query->start_html('Secrets of the Pyramids', + 'fred@capricorn.org','true', + 'BGCOLOR="blue"'); + +This will return a canned HTML header and the opening <BODY> tag. +All parameters are optional. In the named parameter form, recognized +parameters are -title, -author, -base, -xbase and -target (see below for the +explanation). Any additional parameters you provide, such as the +Netscape unofficial BGCOLOR attribute, are added to the <BODY> tag. + +The argument B<-xbase> allows you to provide an HREF for the <BASE> tag +different from the current location, as in + + -xbase=>"http://home.mcom.com/" + +All relative links will be interpreted relative to this tag. + +The argument B<-target> allows you to provide a default target frame +for all the links and fill-out forms on the page. See the Netscape +documentation on frames for details of how to manipulate this. + + -target=>"answer_window" + +All relative links will be interpreted relative to this tag. +You add arbitrary meta information to the header with the B<-meta> +argument. This argument expects a reference to an associative array +containing name/value pairs of meta information. These will be turned +into a series of header <META> tags that look something like this: + + <META NAME="keywords" CONTENT="pharaoh secret mummy"> + <META NAME="description" CONTENT="copyright 1996 King Tut"> + +There is no support for the HTTP-EQUIV type of <META> tag. This is +because you can modify the HTTP header directly with the B<header()> +method. For example, if you want to send the Refresh: header, do it +in the header() method: + + print $q->header(-Refresh=>'10; URL=http://www.capricorn.com'); + +The B<-style> tag is used to incorporate cascading stylesheets into +your code. See the section on CASCADING STYLESHEETS for more information. + +You can place other arbitrary HTML elements to the <HEAD> section with the +B<-head> tag. For example, to place the rarely-used <LINK> element in the +head section, use this: + + print $q->header(-head=>link({-rel=>'next', + -href=>'http://www.capricorn.com/s2.html'})); + +To incorporate multiple HTML elements into the <HEAD> section, just pass an +array reference: + + print $q->header(-head=>[ link({-rel=>'next', + -href=>'http://www.capricorn.com/s2.html'}), + link({-rel=>'previous', + -href=>'http://www.capricorn.com/s1.html'}) + ] + ); + + +JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad> and B<-onUnload> parameters +are used to add Netscape JavaScript calls to your pages. B<-script> +should point to a block of text containing JavaScript function +definitions. This block will be placed within a <SCRIPT> block inside +the HTML (not HTTP) header. The block is placed in the header in +order to give your page a fighting chance of having all its JavaScript +functions in place even if the user presses the stop button before the +page has loaded completely. CGI.pm attempts to format the script in +such a way that JavaScript-naive browsers will not choke on the code: +unfortunately there are some browsers, such as Chimera for Unix, that +get confused by it nevertheless. + +The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript +code to execute when the page is respectively opened and closed by the +browser. Usually these parameters are calls to functions defined in the +B<-script> field: + + $query = new CGI; + print $query->header; + $JSCRIPT=<<END; + // Ask a silly question + function riddle_me_this() { + var r = prompt("What walks on four legs in the morning, " + + "two legs in the afternoon, " + + "and three legs in the evening?"); + response(r); + } + // Get a silly answer + function response(answer) { + if (answer == "man") + alert("Right you are!"); + else + alert("Wrong! Guess again."); + } + END + print $query->start_html(-title=>'The Riddle of the Sphinx', + -script=>$JSCRIPT); + +Use the B<-noScript> parameter to pass some HTML text that will be displayed on +browsers that do not have JavaScript (or browsers where JavaScript is turned +off). + +Netscape 3.0 recognizes several attributes of the <SCRIPT> tag, +including LANGUAGE and SRC. The latter is particularly interesting, +as it allows you to keep the JavaScript code in a file or CGI script +rather than cluttering up each page with the source. To use these +attributes pass a HASH reference in the B<-script> parameter containing +one or more of -language, -src, or -code: + + print $q->start_html(-title=>'The Riddle of the Sphinx', + -script=>{-language=>'JAVASCRIPT', + -src=>'/javascript/sphinx.js'} + ); + + print $q->(-title=>'The Riddle of the Sphinx', + -script=>{-language=>'PERLSCRIPT'}, + -code=>'print "hello world!\n;"' + ); + + +See + + http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/ + +for more information about JavaScript. + +The old-style positional parameters are as follows: + +=over 4 + +=item B<Parameters:> + +=item 1. + +The title + +=item 2. + +The author's e-mail address (will create a <LINK REV="MADE"> tag if present + +=item 3. + +A 'true' flag if you want to include a <BASE> tag in the header. This +helps resolve relative addresses to absolute ones when the document is moved, +but makes the document hierarchy non-portable. Use with care! + +=item 4, 5, 6... + +Any other parameters you want to include in the <BODY> tag. This is a good +place to put Netscape extensions, such as colors and wallpaper patterns. + +=back + +=head2 ENDING THE HTML DOCUMENT: + + print $query->end_html + +This ends an HTML document by printing the </BODY></HTML> tags. + +=head1 CREATING FORMS + +I<General note> The various form-creating methods all return strings +to the caller, containing the tag or tags that will create the requested +form element. You are responsible for actually printing out these strings. +It's set up this way so that you can place formatting tags +around the form elements. + +I<Another note> The default values that you specify for the forms are only +used the B<first> time the script is invoked (when there is no query +string). On subsequent invocations of the script (when there is a query +string), the former values are used even if they are blank. + +If you want to change the value of a field from its previous value, you have two +choices: + +(1) call the param() method to set it. + +(2) use the -override (alias -force) parameter (a new feature in version 2.15). +This forces the default value to be used, regardless of the previous value: + + print $query->textfield(-name=>'field_name', + -default=>'starting value', + -override=>1, + -size=>50, + -maxlength=>80); + +I<Yet another note> By default, the text and labels of form elements are +escaped according to HTML rules. This means that you can safely use +"<CLICK ME>" as the label for a button. However, it also interferes with +your ability to incorporate special HTML character sequences, such as Á, +into your fields. If you wish to turn off automatic escaping, call the +autoEscape() method with a false value immediately after creating the CGI object: + + $query = new CGI; + $query->autoEscape(undef); + + +=head2 CREATING AN ISINDEX TAG + + print $query->isindex(-action=>$action); + + -or- + + print $query->isindex($action); + +Prints out an <ISINDEX> tag. Not very exciting. The parameter +-action specifies the URL of the script to process the query. The +default is to process the query with the current script. + +=head2 STARTING AND ENDING A FORM + + print $query->startform(-method=>$method, + -action=>$action, + -encoding=>$encoding); + <... various form stuff ...> + print $query->endform; + + -or- + + print $query->startform($method,$action,$encoding); + <... various form stuff ...> + print $query->endform; + +startform() will return a <FORM> tag with the optional method, +action and form encoding that you specify. The defaults are: + + method: POST + action: this script + encoding: application/x-www-form-urlencoded + +endform() returns the closing </FORM> tag. + +Startform()'s encoding method tells the browser how to package the various +fields of the form before sending the form to the server. Two +values are possible: + +=over 4 + +=item B<application/x-www-form-urlencoded> + +This is the older type of encoding used by all browsers prior to +Netscape 2.0. It is compatible with many CGI scripts and is +suitable for short fields containing text data. For your +convenience, CGI.pm stores the name of this encoding +type in B<$CGI::URL_ENCODED>. + +=item B<multipart/form-data> + +This is the newer type of encoding introduced by Netscape 2.0. +It is suitable for forms that contain very large fields or that +are intended for transferring binary data. Most importantly, +it enables the "file upload" feature of Netscape 2.0 forms. For +your convenience, CGI.pm stores the name of this encoding type +in B<$CGI::MULTIPART> + +Forms that use this type of encoding are not easily interpreted +by CGI scripts unless they use CGI.pm or another library designed +to handle them. + +=back + +For compatibility, the startform() method uses the older form of +encoding by default. If you want to use the newer form of encoding +by default, you can call B<start_multipart_form()> instead of +B<startform()>. + +JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided +for use with JavaScript. The -name parameter gives the +form a name so that it can be identified and manipulated by +JavaScript functions. -onSubmit should point to a JavaScript +function that will be executed just before the form is submitted to your +server. You can use this opportunity to check the contents of the form +for consistency and completeness. If you find something wrong, you +can put up an alert box or maybe fix things up yourself. You can +abort the submission by returning false from this function. + +Usually the bulk of JavaScript functions are defined in a <SCRIPT> +block in the HTML header and -onSubmit points to one of these function +call. See start_html() for details. + +=head2 CREATING A TEXT FIELD + + print $query->textfield(-name=>'field_name', + -default=>'starting value', + -size=>50, + -maxlength=>80); + -or- + + print $query->textfield('field_name','starting value',50,80); + +textfield() will return a text input field. + +=over 4 + +=item B<Parameters> + +=item 1. + +The first parameter is the required name for the field (-name). + +=item 2. + +The optional second parameter is the default starting value for the field +contents (-default). + +=item 3. + +The optional third parameter is the size of the field in + characters (-size). + +=item 4. + +The optional fourth parameter is the maximum number of characters the + field will accept (-maxlength). + +=back + +As with all these methods, the field will be initialized with its +previous contents from earlier invocations of the script. +When the form is processed, the value of the text field can be +retrieved with: + + $value = $query->param('foo'); + +If you want to reset it from its initial value after the script has been +called once, you can do so like this: + + $query->param('foo',"I'm taking over this value!"); + +NEW AS OF VERSION 2.15: If you don't want the field to take on its previous +value, you can force its current value by using the -override (alias -force) +parameter: + + print $query->textfield(-name=>'field_name', + -default=>'starting value', + -override=>1, + -size=>50, + -maxlength=>80); + +JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>, B<-onBlur> +and B<-onSelect> parameters to register JavaScript event handlers. +The onChange handler will be called whenever the user changes the +contents of the text field. You can do text validation if you like. +onFocus and onBlur are called respectively when the insertion point +moves into and out of the text field. onSelect is called when the +user changes the portion of the text that is selected. + +=head2 CREATING A BIG TEXT FIELD + + print $query->textarea(-name=>'foo', + -default=>'starting value', + -rows=>10, + -columns=>50); + + -or + + print $query->textarea('foo','starting value',10,50); + +textarea() is just like textfield, but it allows you to specify +rows and columns for a multiline text entry box. You can provide +a starting value for the field, which can be long and contain +multiple lines. + +JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> +and B<-onSelect> parameters are recognized. See textfield(). + +=head2 CREATING A PASSWORD FIELD + + print $query->password_field(-name=>'secret', + -value=>'starting value', + -size=>50, + -maxlength=>80); + -or- + + print $query->password_field('secret','starting value',50,80); + +password_field() is identical to textfield(), except that its contents +will be starred out on the web page. + +JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> +and B<-onSelect> parameters are recognized. See textfield(). + +=head2 CREATING A FILE UPLOAD FIELD + + print $query->filefield(-name=>'uploaded_file', + -default=>'starting value', + -size=>50, + -maxlength=>80); + -or- + + print $query->filefield('uploaded_file','starting value',50,80); + +filefield() will return a file upload field for Netscape 2.0 browsers. +In order to take full advantage of this I<you must use the new +multipart encoding scheme> for the form. You can do this either +by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>, +or by calling the new method B<start_multipart_form()> instead of +vanilla B<startform()>. + +=over 4 + +=item B<Parameters> + +=item 1. + +The first parameter is the required name for the field (-name). + +=item 2. + +The optional second parameter is the starting value for the field contents +to be used as the default file name (-default). + +The beta2 version of Netscape 2.0 currently doesn't pay any attention +to this field, and so the starting value will always be blank. Worse, +the field loses its "sticky" behavior and forgets its previous +contents. The starting value field is called for in the HTML +specification, however, and possibly later versions of Netscape will +honor it. + +=item 3. + +The optional third parameter is the size of the field in +characters (-size). + +=item 4. + +The optional fourth parameter is the maximum number of characters the +field will accept (-maxlength). + +=back + +When the form is processed, you can retrieve the entered filename +by calling param(). + + $filename = $query->param('uploaded_file'); + +In Netscape Gold, the filename that gets returned is the full local filename +on the B<remote user's> machine. If the remote user is on a Unix +machine, the filename will follow Unix conventions: + + /path/to/the/file + +On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions: + + C:\PATH\TO\THE\FILE.MSW + +On a Macintosh machine, the filename will follow Mac conventions: + + HD 40:Desktop Folder:Sort Through:Reminders + +The filename returned is also a file handle. You can read the contents +of the file using standard Perl file reading calls: + + # Read a text file and print it out + while (<$filename>) { + print; + } + + # Copy a binary file to somewhere safe + open (OUTFILE,">>/usr/local/web/users/feedback"); + while ($bytesread=read($filename,$buffer,1024)) { + print OUTFILE $buffer; + } + +When a file is uploaded the browser usually sends along some +information along with it in the format of headers. The information +usually includes the MIME content type. Future browsers may send +other information as well (such as modification date and size). To +retrieve this information, call uploadInfo(). It returns a reference to +an associative array containing all the document headers. + + $filename = $query->param('uploaded_file'); + $type = $query->uploadInfo($filename)->{'Content-Type'}; + unless ($type eq 'text/html') { + die "HTML FILES ONLY!"; + } + +If you are using a machine that recognizes "text" and "binary" data +modes, be sure to understand when and how to use them (see the Camel book). +Otherwise you may find that binary files are corrupted during file uploads. + +JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> +and B<-onSelect> parameters are recognized. See textfield() +for details. + +=head2 CREATING A POPUP MENU + + print $query->popup_menu('menu_name', + ['eenie','meenie','minie'], + 'meenie'); + + -or- + + %labels = ('eenie'=>'your first choice', + 'meenie'=>'your second choice', + 'minie'=>'your third choice'); + print $query->popup_menu('menu_name', + ['eenie','meenie','minie'], + 'meenie',\%labels); + + -or (named parameter style)- + + print $query->popup_menu(-name=>'menu_name', + -values=>['eenie','meenie','minie'], + -default=>'meenie', + -labels=>\%labels); + +popup_menu() creates a menu. + +=over 4 + +=item 1. + +The required first argument is the menu's name (-name). + +=item 2. + +The required second argument (-values) is an array B<reference> +containing the list of menu items in the menu. You can pass the +method an anonymous array, as shown in the example, or a reference to +a named array, such as "\@foo". + +=item 3. + +The optional third parameter (-default) is the name of the default +menu choice. If not specified, the first item will be the default. +The values of the previous choice will be maintained across queries. + +=item 4. + +The optional fourth parameter (-labels) is provided for people who +want to use different values for the user-visible label inside the +popup menu nd the value returned to your script. It's a pointer to an +associative array relating menu values to user-visible labels. If you +leave this parameter blank, the menu values will be displayed by +default. (You can also leave a label undefined if you want to). + +=back + +When the form is processed, the selected value of the popup menu can +be retrieved using: + + $popup_menu_value = $query->param('menu_name'); + +JAVASCRIPTING: popup_menu() recognizes the following event handlers: +B<-onChange>, B<-onFocus>, and B<-onBlur>. See the textfield() +section for details on when these handlers are called. + +=head2 CREATING A SCROLLING LIST + + print $query->scrolling_list('list_name', + ['eenie','meenie','minie','moe'], + ['eenie','moe'],5,'true'); + -or- + + print $query->scrolling_list('list_name', + ['eenie','meenie','minie','moe'], + ['eenie','moe'],5,'true', + \%labels); + + -or- + + print $query->scrolling_list(-name=>'list_name', + -values=>['eenie','meenie','minie','moe'], + -default=>['eenie','moe'], + -size=>5, + -multiple=>'true', + -labels=>\%labels); + +scrolling_list() creates a scrolling list. + +=over 4 + +=item B<Parameters:> + +=item 1. + +The first and second arguments are the list name (-name) and values +(-values). As in the popup menu, the second argument should be an +array reference. + +=item 2. + +The optional third argument (-default) can be either a reference to a +list containing the values to be selected by default, or can be a +single value to select. If this argument is missing or undefined, +then nothing is selected when the list first appears. In the named +parameter version, you can use the synonym "-defaults" for this +parameter. + +=item 3. + +The optional fourth argument is the size of the list (-size). + +=item 4. + +The optional fifth argument can be set to true to allow multiple +simultaneous selections (-multiple). Otherwise only one selection +will be allowed at a time. + +=item 5. + +The optional sixth argument is a pointer to an associative array +containing long user-visible labels for the list items (-labels). +If not provided, the values will be displayed. + +When this form is processed, all selected list items will be returned as +a list under the parameter name 'list_name'. The values of the +selected items can be retrieved with: + + @selected = $query->param('list_name'); + +=back + +JAVASCRIPTING: scrolling_list() recognizes the following event handlers: +B<-onChange>, B<-onFocus>, and B<-onBlur>. See textfield() for +the description of when these handlers are called. + +=head2 CREATING A GROUP OF RELATED CHECKBOXES + + print $query->checkbox_group(-name=>'group_name', + -values=>['eenie','meenie','minie','moe'], + -default=>['eenie','moe'], + -linebreak=>'true', + -labels=>\%labels); + + print $query->checkbox_group('group_name', + ['eenie','meenie','minie','moe'], + ['eenie','moe'],'true',\%labels); + + HTML3-COMPATIBLE BROWSERS ONLY: + + print $query->checkbox_group(-name=>'group_name', + -values=>['eenie','meenie','minie','moe'], + -rows=2,-columns=>2); + + +checkbox_group() creates a list of checkboxes that are related +by the same name. + +=over 4 + +=item B<Parameters:> + +=item 1. + +The first and second arguments are the checkbox name and values, +respectively (-name and -values). As in the popup menu, the second +argument should be an array reference. These values are used for the +user-readable labels printed next to the checkboxes as well as for the +values passed to your script in the query string. + +=item 2. + +The optional third argument (-default) can be either a reference to a +list containing the values to be checked by default, or can be a +single value to checked. If this argument is missing or undefined, +then nothing is selected when the list first appears. + +=item 3. + +The optional fourth argument (-linebreak) can be set to true to place +line breaks between the checkboxes so that they appear as a vertical +list. Otherwise, they will be strung together on a horizontal line. + +=item 4. + +The optional fifth argument is a pointer to an associative array +relating the checkbox values to the user-visible labels that will +be printed next to them (-labels). If not provided, the values will +be used as the default. + +=item 5. + +B<HTML3-compatible browsers> (such as Netscape) can take advantage +of the optional +parameters B<-rows>, and B<-columns>. These parameters cause +checkbox_group() to return an HTML3 compatible table containing +the checkbox group formatted with the specified number of rows +and columns. You can provide just the -columns parameter if you +wish; checkbox_group will calculate the correct number of rows +for you. + +To include row and column headings in the returned table, you +can use the B<-rowheader> and B<-colheader> parameters. Both +of these accept a pointer to an array of headings to use. +The headings are just decorative. They don't reorganize the +interpretation of the checkboxes -- they're still a single named +unit. + +=back + +When the form is processed, all checked boxes will be returned as +a list under the parameter name 'group_name'. The values of the +"on" checkboxes can be retrieved with: + + @turned_on = $query->param('group_name'); + +The value returned by checkbox_group() is actually an array of button +elements. You can capture them and use them within tables, lists, +or in other creative ways: + + @h = $query->checkbox_group(-name=>'group_name',-values=>\@values); + &use_in_creative_way(@h); + +JAVASCRIPTING: checkbox_group() recognizes the B<-onClick> +parameter. This specifies a JavaScript code fragment or +function call to be executed every time the user clicks on +any of the buttons in the group. You can retrieve the identity +of the particular button clicked on using the "this" variable. + +=head2 CREATING A STANDALONE CHECKBOX + + print $query->checkbox(-name=>'checkbox_name', + -checked=>'checked', + -value=>'ON', + -label=>'CLICK ME'); + + -or- + + print $query->checkbox('checkbox_name','checked','ON','CLICK ME'); + +checkbox() is used to create an isolated checkbox that isn't logically +related to any others. + +=over 4 + +=item B<Parameters:> + +=item 1. + +The first parameter is the required name for the checkbox (-name). It +will also be used for the user-readable label printed next to the +checkbox. + +=item 2. + +The optional second parameter (-checked) specifies that the checkbox +is turned on by default. Synonyms are -selected and -on. + +=item 3. + +The optional third parameter (-value) specifies the value of the +checkbox when it is checked. If not provided, the word "on" is +assumed. + +=item 4. + +The optional fourth parameter (-label) is the user-readable label to +be attached to the checkbox. If not provided, the checkbox name is +used. + +=back + +The value of the checkbox can be retrieved using: + + $turned_on = $query->param('checkbox_name'); + +JAVASCRIPTING: checkbox() recognizes the B<-onClick> +parameter. See checkbox_group() for further details. + +=head2 CREATING A RADIO BUTTON GROUP + + print $query->radio_group(-name=>'group_name', + -values=>['eenie','meenie','minie'], + -default=>'meenie', + -linebreak=>'true', + -labels=>\%labels); + + -or- + + print $query->radio_group('group_name',['eenie','meenie','minie'], + 'meenie','true',\%labels); + + + HTML3-COMPATIBLE BROWSERS ONLY: + + print $query->radio_group(-name=>'group_name', + -values=>['eenie','meenie','minie','moe'], + -rows=2,-columns=>2); + +radio_group() creates a set of logically-related radio buttons +(turning one member of the group on turns the others off) + +=over 4 + +=item B<Parameters:> + +=item 1. + +The first argument is the name of the group and is required (-name). + +=item 2. + +The second argument (-values) is the list of values for the radio +buttons. The values and the labels that appear on the page are +identical. Pass an array I<reference> in the second argument, either +using an anonymous array, as shown, or by referencing a named array as +in "\@foo". + +=item 3. + +The optional third parameter (-default) is the name of the default +button to turn on. If not specified, the first item will be the +default. You can provide a nonexistent button name, such as "-" to +start up with no buttons selected. + +=item 4. + +The optional fourth parameter (-linebreak) can be set to 'true' to put +line breaks between the buttons, creating a vertical list. + +=item 5. + +The optional fifth parameter (-labels) is a pointer to an associative +array relating the radio button values to user-visible labels to be +used in the display. If not provided, the values themselves are +displayed. + +=item 6. + +B<HTML3-compatible browsers> (such as Netscape) can take advantage +of the optional +parameters B<-rows>, and B<-columns>. These parameters cause +radio_group() to return an HTML3 compatible table containing +the radio group formatted with the specified number of rows +and columns. You can provide just the -columns parameter if you +wish; radio_group will calculate the correct number of rows +for you. + +To include row and column headings in the returned table, you +can use the B<-rowheader> and B<-colheader> parameters. Both +of these accept a pointer to an array of headings to use. +The headings are just decorative. They don't reorganize the +interpetation of the radio buttons -- they're still a single named +unit. + +=back + +When the form is processed, the selected radio button can +be retrieved using: + + $which_radio_button = $query->param('group_name'); + +The value returned by radio_group() is actually an array of button +elements. You can capture them and use them within tables, lists, +or in other creative ways: + + @h = $query->radio_group(-name=>'group_name',-values=>\@values); + &use_in_creative_way(@h); + +=head2 CREATING A SUBMIT BUTTON + + print $query->submit(-name=>'button_name', + -value=>'value'); + + -or- + + print $query->submit('button_name','value'); + +submit() will create the query submission button. Every form +should have one of these. + +=over 4 + +=item B<Parameters:> + +=item 1. + +The first argument (-name) is optional. You can give the button a +name if you have several submission buttons in your form and you want +to distinguish between them. The name will also be used as the +user-visible label. Be aware that a few older browsers don't deal with this correctly and +B<never> send back a value from a button. + +=item 2. + +The second argument (-value) is also optional. This gives the button +a value that will be passed to your script in the query string. + +=back + +You can figure out which button was pressed by using different +values for each one: + + $which_one = $query->param('button_name'); + +JAVASCRIPTING: radio_group() recognizes the B<-onClick> +parameter. See checkbox_group() for further details. + +=head2 CREATING A RESET BUTTON + + print $query->reset + +reset() creates the "reset" button. Note that it restores the +form to its value from the last time the script was called, +NOT necessarily to the defaults. + +=head2 CREATING A DEFAULT BUTTON + + print $query->defaults('button_label') + +defaults() creates a button that, when invoked, will cause the +form to be completely reset to its defaults, wiping out all the +changes the user ever made. + +=head2 CREATING A HIDDEN FIELD + + print $query->hidden(-name=>'hidden_name', + -default=>['value1','value2'...]); + + -or- + + print $query->hidden('hidden_name','value1','value2'...); + +hidden() produces a text field that can't be seen by the user. It +is useful for passing state variable information from one invocation +of the script to the next. + +=over 4 + +=item B<Parameters:> + +=item 1. + +The first argument is required and specifies the name of this +field (-name). + +=item 2. + +The second argument is also required and specifies its value +(-default). In the named parameter style of calling, you can provide +a single value here or a reference to a whole list + +=back + +Fetch the value of a hidden field this way: + + $hidden_value = $query->param('hidden_name'); + +Note, that just like all the other form elements, the value of a +hidden field is "sticky". If you want to replace a hidden field with +some other values after the script has been called once you'll have to +do it manually: + + $query->param('hidden_name','new','values','here'); + +=head2 CREATING A CLICKABLE IMAGE BUTTON + + print $query->image_button(-name=>'button_name', + -src=>'/source/URL', + -align=>'MIDDLE'); + + -or- + + print $query->image_button('button_name','/source/URL','MIDDLE'); + +image_button() produces a clickable image. When it's clicked on the +position of the click is returned to your script as "button_name.x" +and "button_name.y", where "button_name" is the name you've assigned +to it. + +JAVASCRIPTING: image_button() recognizes the B<-onClick> +parameter. See checkbox_group() for further details. + +=over 4 + +=item B<Parameters:> + +=item 1. + +The first argument (-name) is required and specifies the name of this +field. + +=item 2. + +The second argument (-src) is also required and specifies the URL + +=item 3. +The third option (-align, optional) is an alignment type, and may be +TOP, BOTTOM or MIDDLE + +=back + +Fetch the value of the button this way: + $x = $query->param('button_name.x'); + $y = $query->param('button_name.y'); + +=head2 CREATING A JAVASCRIPT ACTION BUTTON + + print $query->button(-name=>'button_name', + -value=>'user visible label', + -onClick=>"do_something()"); + + -or- + + print $query->button('button_name',"do_something()"); + +button() produces a button that is compatible with Netscape 2.0's +JavaScript. When it's pressed the fragment of JavaScript code +pointed to by the B<-onClick> parameter will be executed. On +non-Netscape browsers this form element will probably not even +display. + +=head1 NETSCAPE COOKIES + +Netscape browsers versions 1.1 and higher support a so-called +"cookie" designed to help maintain state within a browser session. +CGI.pm has several methods that support cookies. + +A cookie is a name=value pair much like the named parameters in a CGI +query string. CGI scripts create one or more cookies and send +them to the browser in the HTTP header. The browser maintains a list +of cookies that belong to a particular Web server, and returns them +to the CGI script during subsequent interactions. + +In addition to the required name=value pair, each cookie has several +optional attributes: + +=over 4 + +=item 1. an expiration time + +This is a time/date string (in a special GMT format) that indicates +when a cookie expires. The cookie will be saved and returned to your +script until this expiration date is reached if the user exits +Netscape and restarts it. If an expiration date isn't specified, the cookie +will remain active until the user quits Netscape. + +=item 2. a domain + +This is a partial or complete domain name for which the cookie is +valid. The browser will return the cookie to any host that matches +the partial domain name. For example, if you specify a domain name +of ".capricorn.com", then Netscape will return the cookie to +Web servers running on any of the machines "www.capricorn.com", +"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names +must contain at least two periods to prevent attempts to match +on top level domains like ".edu". If no domain is specified, then +the browser will only return the cookie to servers on the host the +cookie originated from. + +=item 3. a path + +If you provide a cookie path attribute, the browser will check it +against your script's URL before returning the cookie. For example, +if you specify the path "/cgi-bin", then the cookie will be returned +to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl", +and "/cgi-bin/customer_service/complain.pl", but not to the script +"/cgi-private/site_admin.pl". By default, path is set to "/", which +causes the cookie to be sent to any CGI script on your site. + +=item 4. a "secure" flag + +If the "secure" attribute is set, the cookie will only be sent to your +script if the CGI request is occurring on a secure channel, such as SSL. + +=back + +The interface to Netscape cookies is the B<cookie()> method: + + $cookie = $query->cookie(-name=>'sessionID', + -value=>'xyzzy', + -expires=>'+1h', + -path=>'/cgi-bin/database', + -domain=>'.capricorn.org', + -secure=>1); + print $query->header(-cookie=>$cookie); + +B<cookie()> creates a new cookie. Its parameters include: + +=over 4 + +=item B<-name> + +The name of the cookie (required). This can be any string at all. +Although Netscape limits its cookie names to non-whitespace +alphanumeric characters, CGI.pm removes this restriction by escaping +and unescaping cookies behind the scenes. + +=item B<-value> + +The value of the cookie. This can be any scalar value, +array reference, or even associative array reference. For example, +you can store an entire associative array into a cookie this way: + + $cookie=$query->cookie(-name=>'family information', + -value=>\%childrens_ages); + +=item B<-path> + +The optional partial path for which this cookie will be valid, as described +above. + +=item B<-domain> + +The optional partial domain for which this cookie will be valid, as described +above. + +=item B<-expires> + +The optional expiration date for this cookie. The format is as described +in the section on the B<header()> method: + + "+1h" one hour from now + +=item B<-secure> + +If set to true, this cookie will only be used within a secure +SSL session. + +=back + +The cookie created by cookie() must be incorporated into the HTTP +header within the string returned by the header() method: + + print $query->header(-cookie=>$my_cookie); + +To create multiple cookies, give header() an array reference: + + $cookie1 = $query->cookie(-name=>'riddle_name', + -value=>"The Sphynx's Question"); + $cookie2 = $query->cookie(-name=>'answers', + -value=>\%answers); + print $query->header(-cookie=>[$cookie1,$cookie2]); + +To retrieve a cookie, request it by name by calling cookie() +method without the B<-value> parameter: + + use CGI; + $query = new CGI; + %answers = $query->cookie(-name=>'answers'); + # $query->cookie('answers') will work too! + +The cookie and CGI namespaces are separate. If you have a parameter +named 'answers' and a cookie named 'answers', the values retrieved by +param() and cookie() are independent of each other. However, it's +simple to turn a CGI parameter into a cookie, and vice-versa: + + # turn a CGI parameter into a cookie + $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]); + # vice-versa + $q->param(-name=>'answers',-value=>[$q->cookie('answers')]); + +See the B<cookie.cgi> example script for some ideas on how to use +cookies effectively. + +B<NOTE:> There appear to be some (undocumented) restrictions on +Netscape cookies. In Netscape 2.01, at least, I haven't been able to +set more than three cookies at a time. There may also be limits on +the length of cookies. If you need to store a lot of information, +it's probably better to create a unique session ID, store it in a +cookie, and use the session ID to locate an external file/database +saved on the server's side of the connection. + +=head1 WORKING WITH NETSCAPE FRAMES + +It's possible for CGI.pm scripts to write into several browser +panels and windows using Netscape's frame mechanism. +There are three techniques for defining new frames programmatically: + +=over 4 + +=item 1. Create a <Frameset> document + +After writing out the HTTP header, instead of creating a standard +HTML document using the start_html() call, create a <FRAMESET> +document that defines the frames on the page. Specify your script(s) +(with appropriate parameters) as the SRC for each of the frames. + +There is no specific support for creating <FRAMESET> sections +in CGI.pm, but the HTML is very simple to write. See the frame +documentation in Netscape's home pages for details + + http://home.netscape.com/assist/net_sites/frames.html + +=item 2. Specify the destination for the document in the HTTP header + +You may provide a B<-target> parameter to the header() method: + + print $q->header(-target=>'ResultsWindow'); + +This will tell Netscape to load the output of your script into the +frame named "ResultsWindow". If a frame of that name doesn't +already exist, Netscape will pop up a new window and load your +script's document into that. There are a number of magic names +that you can use for targets. See the frame documents on Netscape's +home pages for details. + +=item 3. Specify the destination for the document in the <FORM> tag + +You can specify the frame to load in the FORM tag itself. With +CGI.pm it looks like this: + + print $q->startform(-target=>'ResultsWindow'); + +When your script is reinvoked by the form, its output will be loaded +into the frame named "ResultsWindow". If one doesn't already exist +a new window will be created. + +=back + +The script "frameset.cgi" in the examples directory shows one way to +create pages in which the fill-out form and the response live in +side-by-side frames. + +=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS + +CGI.pm has limited support for HTML3's cascading style sheets (css). +To incorporate a stylesheet into your document, pass the +start_html() method a B<-style> parameter. The value of this +parameter may be a scalar, in which case it is incorporated directly +into a <STYLE> section, or it may be a hash reference. In the latter +case you should provide the hash with one or more of B<-src> or +B<-code>. B<-src> points to a URL where an externally-defined +stylesheet can be found. B<-code> points to a scalar value to be +incorporated into a <STYLE> section. Style definitions in B<-code> +override similarly-named ones in B<-src>, hence the name "cascading." + +To refer to a style within the body of your document, add the +B<-class> parameter to any HTML element: + + print h1({-class=>'Fancy'},'Welcome to the Party'); + +Or define styles on the fly with the B<-style> parameter: + + print h1({-style=>'Color: red;'},'Welcome to Hell'); + +You may also use the new B<span()> element to apply a style to a +section of text: + + print span({-style=>'Color: red;'}, + h1('Welcome to Hell'), + "Where did that handbasket get to?" + ); + +Note that you must import the ":html3" definitions to have the +B<span()> method available. Here's a quick and dirty example of using +CSS's. See the CSS specification at +http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information. + + use CGI qw/:standard :html3/; + + #here's a stylesheet incorporated directly into the page + $newStyle=<<END; + <!-- + P.Tip { + margin-right: 50pt; + margin-left: 50pt; + color: red; + } + P.Alert { + font-size: 30pt; + font-family: sans-serif; + color: red; + } + --> + END + print header(); + print start_html( -title=>'CGI with Style', + -style=>{-src=>'http://www.capricorn.com/style/st1.css', + -code=>$newStyle} + ); + print h1('CGI with Style'), + p({-class=>'Tip'}, + "Better read the cascading style sheet spec before playing with this!"), + span({-style=>'color: magenta'}, + "Look Mom, no hands!", + p(), + "Whooo wee!" + ); + print end_html; + +=head1 DEBUGGING + +If you are running the script +from the command line or in the perl debugger, you can pass the script +a list of keywords or parameter=value pairs on the command line or +from standard input (you don't have to worry about tricking your +script into reading from environment variables). +You can pass keywords like this: + + your_script.pl keyword1 keyword2 keyword3 + +or this: + + your_script.pl keyword1+keyword2+keyword3 + +or this: + + your_script.pl name1=value1 name2=value2 + +or this: + + your_script.pl name1=value1&name2=value2 + +or even as newline-delimited parameters on standard input. + +When debugging, you can use quotes and backslashes to escape +characters in the familiar shell manner, letting you place +spaces and other funny characters in your parameter=value +pairs: + + your_script.pl "name1='I am a long value'" "name2=two\ words" + +=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS + +The dump() method produces a string consisting of all the query's +name/value pairs formatted nicely as a nested list. This is useful +for debugging purposes: + + print $query->dump + + +Produces something that looks like: + + <UL> + <LI>name1 + <UL> + <LI>value1 + <LI>value2 + </UL> + <LI>name2 + <UL> + <LI>value1 + </UL> + </UL> + +You can pass a value of 'true' to dump() in order to get it to +print the results out as plain text, suitable for incorporating +into a <PRE> section. + +As a shortcut, as of version 1.56 you can interpolate the entire CGI +object into a string and it will be replaced with the a nice HTML dump +shown above: + + $query=new CGI; + print "<H2>Current Values</H2> $query\n"; + +=head1 FETCHING ENVIRONMENT VARIABLES + +Some of the more useful environment variables can be fetched +through this interface. The methods are as follows: + +=over 4 + +=item B<accept()> + +Return a list of MIME types that the remote browser +accepts. If you give this method a single argument +corresponding to a MIME type, as in +$query->accept('text/html'), it will return a +floating point value corresponding to the browser's +preference for this type from 0.0 (don't want) to 1.0. +Glob types (e.g. text/*) in the browser's accept list +are handled correctly. + +=item B<raw_cookie()> + +Returns the HTTP_COOKIE variable, an HTTP extension +implemented by Netscape browsers version 1.1 +and higher. Cookies have a special format, and this +method call just returns the raw form (?cookie dough). +See cookie() for ways of setting and retrieving +cooked cookies. + +=item B<user_agent()> + +Returns the HTTP_USER_AGENT variable. If you give +this method a single argument, it will attempt to +pattern match on it, allowing you to do something +like $query->user_agent(netscape); + +=item B<path_info()> + +Returns additional path information from the script URL. +E.G. fetching /cgi-bin/your_script/additional/stuff will +result in $query->path_info() returning +"additional/stuff". + +NOTE: The Microsoft Internet Information Server +is broken with respect to additional path information. If +you use the Perl DLL library, the IIS server will attempt to +execute the additional path information as a Perl script. +If you use the ordinary file associations mapping, the +path information will be present in the environment, +but incorrect. The best thing to do is to avoid using additional +path information in CGI scripts destined for use with IIS. + +=item B<path_translated()> + +As per path_info() but returns the additional +path information translated into a physical path, e.g. +"/usr/local/etc/httpd/htdocs/additional/stuff". + +The Microsoft IIS is broken with respect to the translated +path as well. + +=item B<remote_host()> + +Returns either the remote host name or IP address. +if the former is unavailable. + +=item B<script_name()> +Return the script name as a partial URL, for self-refering +scripts. + +=item B<referer()> + +Return the URL of the page the browser was viewing +prior to fetching your script. Not available for all +browsers. + +=item B<auth_type ()> + +Return the authorization/verification method in use for this +script, if any. + +=item B<server_name ()> + +Returns the name of the server, usually the machine's host +name. + +=item B<virtual_host ()> + +When using virtual hosts, returns the name of the host that +the browser attempted to contact + +=item B<server_software ()> + +Returns the server software and version number. + +=item B<remote_user ()> + +Return the authorization/verification name used for user +verification, if this script is protected. + +=item B<user_name ()> + +Attempt to obtain the remote user's name, using a variety +of different techniques. This only works with older browsers +such as Mosaic. Netscape does not reliably report the user +name! + +=item B<request_method()> + +Returns the method used to access your script, usually +one of 'POST', 'GET' or 'HEAD'. + +=back + +=head1 CREATING HTML ELEMENTS + +In addition to its shortcuts for creating form elements, CGI.pm +defines general HTML shortcut methods as well. HTML shortcuts are +named after a single HTML element and return a fragment of HTML text +that you can then print or manipulate as you like. + +This example shows how to use the HTML methods: + + $q = new CGI; + print $q->blockquote( + "Many years ago on the island of", + $q->a({href=>"http://crete.org/"},"Crete"), + "there lived a minotaur named", + $q->strong("Fred."), + ), + $q->hr; + +This results in the following HTML code (extra newlines have been +added for readability): + + <blockquote> + Many years ago on the island of + <a HREF="http://crete.org/">Crete</a> there lived + a minotaur named <strong>Fred.</strong> + </blockquote> + <hr> + +If you find the syntax for calling the HTML shortcuts awkward, you can +import them into your namespace and dispense with the object syntax +completely (see the next section for more details): + + use CGI shortcuts; # IMPORT HTML SHORTCUTS + print blockquote( + "Many years ago on the island of", + a({href=>"http://crete.org/"},"Crete"), + "there lived a minotaur named", + strong("Fred."), + ), + hr; + +=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS + +The HTML methods will accept zero, one or multiple arguments. If you +provide no arguments, you get a single tag: + + print hr; + # gives "<hr>" + +If you provide one or more string arguments, they are concatenated +together with spaces and placed between opening and closing tags: + + print h1("Chapter","1"); + # gives "<h1>Chapter 1</h1>" + +If the first argument is an associative array reference, then the keys +and values of the associative array become the HTML tag's attributes: + + print a({href=>'fred.html',target=>'_new'}, + "Open a new frame"); + # gives <a href="fred.html",target="_new">Open a new frame</a> + +You are free to use CGI.pm-style dashes in front of the attribute +names if you prefer: + + print img {-src=>'fred.gif',-align=>'LEFT'}; + # gives <img ALIGN="LEFT" SRC="fred.gif"> + +=head2 Generating new HTML tags + +Since no mere mortal can keep up with Netscape and Microsoft as they +battle it out for control of HTML, the code that generates HTML tags +is general and extensible. You can create new HTML tags freely just +by referring to them on the import line: + + use CGI shortcuts,winkin,blinkin,nod; + +Now, in addition to the standard CGI shortcuts, you've created HTML +tags named "winkin", "blinkin" and "nod". You can use them like this: + + print blinkin {color=>'blue',rate=>'fast'},"Yahoo!"; + # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin> + +=head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE + +As a convenience, you can import most of the CGI method calls directly +into your name space. The syntax for doing this is: + + use CGI <list of methods>; + +The listed methods will be imported into the current package; you can +call them directly without creating a CGI object first. This example +shows how to import the B<param()> and B<header()> +methods, and then use them directly: + + use CGI param,header; + print header('text/plain'); + $zipcode = param('zipcode'); + +You can import groups of methods by referring to a number of special +names: + +=over 4 + +=item B<cgi> + +Import all CGI-handling methods, such as B<param()>, B<path_info()> +and the like. + +=item B<form> + +Import all fill-out form generating methods, such as B<textfield()>. + +=item B<html2> + +Import all methods that generate HTML 2.0 standard elements. + +=item B<html3> + +Import all methods that generate HTML 3.0 proposed elements (such as +<table>, <super> and <sub>). + +=item B<netscape> + +Import all methods that generate Netscape-specific HTML extensions. + +=item B<shortcuts> + +Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' + +'netscape')... + +=item B<standard> + +Import "standard" features, 'html2', 'form' and 'cgi'. + +=item B<all> + +Import all the available methods. For the full list, see the CGI.pm +code, where the variable %TAGS is defined. + +=back + +Note that in the interests of execution speed CGI.pm does B<not> use +the standard L<Exporter> syntax for specifying load symbols. This may +change in the future. + +If you import any of the state-maintaining CGI or form-generating +methods, a default CGI object will be created and initialized +automatically the first time you use any of the methods that require +one to be present. This includes B<param()>, B<textfield()>, +B<submit()> and the like. (If you need direct access to the CGI +object, you can find it in the global variable B<$CGI::Q>). By +importing CGI.pm methods, you can create visually elegant scripts: + + use CGI standard,html2; + print + header, + start_html('Simple Script'), + h1('Simple Script'), + start_form, + "What's your name? ",textfield('name'),p, + "What's the combination?", + checkbox_group(-name=>'words', + -values=>['eenie','meenie','minie','moe'], + -defaults=>['eenie','moe']),p, + "What's your favorite color?", + popup_menu(-name=>'color', + -values=>['red','green','blue','chartreuse']),p, + submit, + end_form, + hr,"\n"; + + if (param) { + print + "Your name is ",em(param('name')),p, + "The keywords are: ",em(join(", ",param('words'))),p, + "Your favorite color is ",em(param('color')),".\n"; + } + print end_html; + +=head1 USING NPH SCRIPTS + +NPH, or "no-parsed-header", scripts bypass the server completely by +sending the complete HTTP header directly to the browser. This has +slight performance benefits, but is of most use for taking advantage +of HTTP extensions that are not directly supported by your server, +such as server push and PICS headers. + +Servers use a variety of conventions for designating CGI scripts as +NPH. Many Unix servers look at the beginning of the script's name for +the prefix "nph-". The Macintosh WebSTAR server and Microsoft's +Internet Information Server, in contrast, try to decide whether a +program is an NPH script by examining the first line of script output. + + +CGI.pm supports NPH scripts with a special NPH mode. When in this +mode, CGI.pm will output the necessary extra header information when +the header() and redirect() methods are +called. + +The Microsoft Internet Information Server requires NPH mode. As of version +2.30, CGI.pm will automatically detect when the script is running under IIS +and put itself into this mode. You do not need to do this manually, although +it won't hurt anything if you do. + +There are a number of ways to put CGI.pm into NPH mode: + +=over 4 + +=item In the B<use> statement +Simply add ":nph" to the list of symbols to be imported into your script: + + use CGI qw(:standard :nph) + +=item By calling the B<nph()> method: + +Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program. + + CGI->nph(1) + +=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements: + + print $q->header(-nph=>1); + +=back + +=head1 AUTHOR INFORMATION + +Copyright 1995,1996, Lincoln D. Stein. All rights reserved. It may +be used and modified freely, but I do request that this copyright +notice remain attached to the file. You may modify this module as you +wish, but if you redistribute a modified version, please attach a note +listing the modifications you have made. + +Address bug reports and comments to: +lstein@genome.wi.mit.edu + +=head1 CREDITS + +Thanks very much to: + +=over 4 + +=item Matt Heffron (heffron@falstaff.css.beckman.com) + +=item James Taylor (james.taylor@srs.gov) + +=item Scott Anguish <sanguish@digifix.com> + +=item Mike Jewell (mlj3u@virginia.edu) + +=item Timothy Shimmin (tes@kbs.citri.edu.au) + +=item Joergen Haegg (jh@axis.se) + +=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu) + +=item Richard Resnick (applepi1@aol.com) + +=item Craig Bishop (csb@barwonwater.vic.gov.au) + +=item Tony Curtis (tc@vcpc.univie.ac.at) + +=item Tim Bunce (Tim.Bunce@ig.co.uk) + +=item Tom Christiansen (tchrist@convex.com) + +=item Andreas Koenig (k@franz.ww.TU-Berlin.DE) + +=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au) + +=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu) + +=item Stephen Dahmen (joyfire@inxpress.net) + +=item Ed Jordan (ed@fidalgo.net) + +=item David Alan Pisoni (david@cnation.com) + +=item ...and many many more... + +for suggestions and bug fixes. + +=back + +=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT + + + #!/usr/local/bin/perl + + use CGI; + + $query = new CGI; + + print $query->header; + print $query->start_html("Example CGI.pm Form"); + print "<H1> Example CGI.pm Form</H1>\n"; + &print_prompt($query); + &do_work($query); + &print_tail; + print $query->end_html; + + sub print_prompt { + my($query) = @_; + + print $query->startform; + print "<EM>What's your name?</EM><BR>"; + print $query->textfield('name'); + print $query->checkbox('Not my real name'); + + print "<P><EM>Where can you find English Sparrows?</EM><BR>"; + print $query->checkbox_group( + -name=>'Sparrow locations', + -values=>[England,France,Spain,Asia,Hoboken], + -linebreak=>'yes', + -defaults=>[England,Asia]); + + print "<P><EM>How far can they fly?</EM><BR>", + $query->radio_group( + -name=>'how far', + -values=>['10 ft','1 mile','10 miles','real far'], + -default=>'1 mile'); + + print "<P><EM>What's your favorite color?</EM> "; + print $query->popup_menu(-name=>'Color', + -values=>['black','brown','red','yellow'], + -default=>'red'); + + print $query->hidden('Reference','Monty Python and the Holy Grail'); + + print "<P><EM>What have you got there?</EM><BR>"; + print $query->scrolling_list( + -name=>'possessions', + -values=>['A Coconut','A Grail','An Icon', + 'A Sword','A Ticket'], + -size=>5, + -multiple=>'true'); + + print "<P><EM>Any parting comments?</EM><BR>"; + print $query->textarea(-name=>'Comments', + -rows=>10, + -columns=>50); + + print "<P>",$query->reset; + print $query->submit('Action','Shout'); + print $query->submit('Action','Scream'); + print $query->endform; + print "<HR>\n"; + } + + sub do_work { + my($query) = @_; + my(@values,$key); + + print "<H2>Here are the current settings in this form</H2>"; + + foreach $key ($query->param) { + print "<STRONG>$key</STRONG> -> "; + @values = $query->param($key); + print join(", ",@values),"<BR>\n"; + } + } + + sub print_tail { + print <<END; + <HR> + <ADDRESS>Lincoln D. Stein</ADDRESS><BR> + <A HREF="/">Home Page</A> + END + } + +=head1 BUGS + +This module has grown large and monolithic. Furthermore it's doing many +things, such as handling URLs, parsing CGI input, writing HTML, etc., that +are also done in the LWP modules. It should be discarded in favor of +the CGI::* modules, but somehow I continue to work on it. + +Note that the code is truly contorted in order to avoid spurious +warnings when programs are run with the B<-w> switch. + +=head1 SEE ALSO + +L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>, +L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>, +L<CGI::Push>, L<CGI::Fast> + +=cut + diff --git a/gnu/usr.bin/perl/lib/CGI/Apache.pm b/gnu/usr.bin/perl/lib/CGI/Apache.pm new file mode 100644 index 00000000000..6ea7523c571 --- /dev/null +++ b/gnu/usr.bin/perl/lib/CGI/Apache.pm @@ -0,0 +1,103 @@ +package CGI::Apache; +use Apache (); +use vars qw(@ISA $VERSION); +require CGI; +@ISA = qw(CGI); + +$VERSION = (qw$Revision: 1.1 $)[1]; +$CGI::DefaultClass = 'CGI::Apache'; +$CGI::Apache::AutoloadClass = 'CGI'; + +sub import { + my $self = shift; + my ($callpack, $callfile, $callline) = caller; + ${"${callpack}::AutoloadClass"} = 'CGI'; +} + +sub new { + my($class) = shift; + my($r) = Apache->request; + %ENV = $r->cgi_env unless defined $ENV{GATEWAY_INTERFACE}; #PerlSetupEnv On + my $self = $class->SUPER::new(@_); + $self->{'.req'} = $r; + $self; +} + +sub header { + my ($self,@rest) = CGI::self_or_default(@_); + my $r = $self->{'.req'}; + $r->basic_http_header; + return CGI::header($self,@rest); +} + +sub print { + my($self,@rest) = CGI::self_or_default(@_); + $self->{'.req'}->print(@rest); +} + +sub read_from_client { + my($self, $fh, $buff, $len, $offset) = @_; + my $r = $self->{'.req'} || Apache->request; + return $r->read($$buff, $len, $offset); +} + +sub new_MultipartBuffer { + my $self = shift; + my $new = CGI::Apache::MultipartBuffer->new($self, @_); + $new->{'.req'} = $self->{'.req'} || Apache->request; + return $new; +} + +package CGI::Apache::MultipartBuffer; +use vars qw(@ISA); +@ISA = qw(MultipartBuffer); + +$CGI::Apache::MultipartBuffer::AutoloadClass = 'MultipartBuffer'; +*CGI::Apache::MultipartBuffer::read_from_client = + \&CGI::Apache::read_from_client; + + +1; + +__END__ + +=head1 NAME + +CGI::Apache - Make things work with CGI.pm against Perl-Apache API + +=head1 SYNOPSIS + + require CGI::Apache; + + my $q = new Apache::CGI; + + $q->print($q->header); + + #do things just like you do with CGI.pm + +=head1 DESCRIPTION + +When using the Perl-Apache API, your applications are faster, but the +enviroment is different than CGI. +This module attempts to set-up that environment as best it can. + +=head1 NOTE 1 + +This module used to be named Apache::CGI. Sorry for the confusion. + +=head1 NOTE 2 + +If you're going to inherit from this class, make sure to "use" it +after your package declaration rather than "require" it. This is +because CGI.pm does a little magic during the import() step in order +to make autoloading work correctly. + +=head1 SEE ALSO + +perl(1), Apache(3), CGI(3) + +=head1 AUTHOR + +Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas König E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt> + +=cut diff --git a/gnu/usr.bin/perl/lib/CGI/Carp.pm b/gnu/usr.bin/perl/lib/CGI/Carp.pm new file mode 100644 index 00000000000..4cd79467fd8 --- /dev/null +++ b/gnu/usr.bin/perl/lib/CGI/Carp.pm @@ -0,0 +1,242 @@ +package CGI::Carp; + +=head1 NAME + +B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log + +=head1 SYNOPSIS + + use CGI::Carp; + + croak "We're outta here!"; + confess "It was my fault: $!"; + carp "It was your fault!"; + warn "I'm confused"; + die "I'm dying.\n"; + +=head1 DESCRIPTION + +CGI scripts have a nasty habit of leaving warning messages in the error +logs that are neither time stamped nor fully identified. Tracking down +the script that caused the error is a pain. This fixes that. Replace +the usual + + use Carp; + +with + + use CGI::Carp + +And the standard warn(), die (), croak(), confess() and carp() calls +will automagically be replaced with functions that write out nicely +time-stamped messages to the HTTP server error log. + +For example: + + [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3. + [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied. + [Fri Nov 17 21:40:43 1995] test.pl: I'm dying. + +=head1 REDIRECTING ERROR MESSAGES + +By default, error messages are sent to STDERR. Most HTTPD servers +direct STDERR to the server's error log. Some applications may wish +to keep private error logs, distinct from the server's error log, or +they may wish to direct error messages to STDOUT so that the browser +will receive them. + +The C<carpout()> function is provided for this purpose. Since +carpout() is not exported by default, you must import it explicitly by +saying + + use CGI::Carp qw(carpout); + +The carpout() function requires one argument, which should be a +reference to an open filehandle for writing errors. It should be +called in a C<BEGIN> block at the top of the CGI application so that +compiler errors will be caught. Example: + + BEGIN { + use CGI::Carp qw(carpout); + open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or + die("Unable to open mycgi-log: $!\n"); + carpout(LOG); + } + +carpout() does not handle file locking on the log for you at this point. + +The real STDERR is not closed -- it is moved to SAVEERR. Some +servers, when dealing with CGI scripts, close their connection to the +browser when the script closes STDOUT and STDERR. SAVEERR is used to +prevent this from happening prematurely. + +You can pass filehandles to carpout() in a variety of ways. The "correct" +way according to Tom Christiansen is to pass a reference to a filehandle +GLOB: + + carpout(\*LOG); + +This looks weird to mere mortals however, so the following syntaxes are +accepted as well: + + carpout(LOG); + carpout(main::LOG); + carpout(main'LOG); + carpout(\LOG); + carpout(\'main::LOG'); + + ... and so on + +Use of carpout() is not great for performance, so it is recommended +for debugging purposes or for moderate-use applications. A future +version of this module may delay redirecting STDERR until one of the +CGI::Carp methods is called to prevent the performance hit. + +=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW + +If you want to send fatal (die, confess) errors to the browser, ask to +import the special "fatalsToBrowser" subroutine: + + use CGI::Carp qw(fatalsToBrowser); + die "Bad error here"; + +Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp +arranges to send a minimal HTTP header to the browser so that even errors that +occur in the early compile phase will be seen. +Nonfatal errors will still be directed to the log file only (unless redirected +with carpout). + +=head1 CHANGE LOG + +1.05 carpout() added and minor corrections by Marc Hedlund + <hedlund@best.com> on 11/26/95. + +1.06 fatalsToBrowser() no longer aborts for fatal errors within + eval() statements. + +=head1 AUTHORS + +Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute +this under the Perl Artistic License. + + +=head1 SEE ALSO + +Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form, +CGI::Response + +=cut + +require 5.000; +use Exporter; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(carpout fatalsToBrowser); + +$main::SIG{__WARN__}=\&CGI::Carp::warn; +$main::SIG{__DIE__}=\&CGI::Carp::die; +$CGI::Carp::VERSION = '1.06'; + +# fancy import routine detects and handles 'errorWrap' specially. +sub import { + my $pkg = shift; + my(%routines); + grep($routines{$_}++,@_); + $WRAP++ if $routines{'fatalsToBrowser'}; + my($oldlevel) = $Exporter::ExportLevel; + $Exporter::ExportLevel = 1; + Exporter::import($pkg,keys %routines); + $Exporter::ExportLevel = $oldlevel; +} + +# These are the originals +sub realwarn { warn(@_); } +sub realdie { die(@_); } + +sub id { + my $level = shift; + my($pack,$file,$line,$sub) = caller($level); + my($id) = $file=~m|([^/]+)$|; + return ($file,$line,$id); +} + +sub stamp { + my $time = scalar(localtime); + my $frame = 0; + my ($id,$pack,$file); + do { + $id = $file; + ($pack,$file) = caller($frame++); + } until !$file; + ($id) = $id=~m|([^/]+)$|; + return "[$time] $id: "; +} + +sub warn { + my $message = shift; + my($file,$line,$id) = id(1); + $message .= " at $file line $line.\n" unless $message=~/\n$/; + my $stamp = stamp; + $message=~s/^/$stamp/gm; + realwarn $message; +} + +sub die { + my $message = shift; + my $time = scalar(localtime); + my($file,$line,$id) = id(1); + return undef if $file=~/^\(eval/; + $message .= " at $file line $line.\n" unless $message=~/\n$/; + &fatalsToBrowser($message) if $WRAP; + my $stamp = stamp; + $message=~s/^/$stamp/gm; + realdie $message; +} + +# Avoid generating "subroutine redefined" warnings with the following +# hack: +{ + local $^W=0; + eval <<EOF; +sub confess { CGI::Carp::die Carp::longmess \@_; } +sub croak { CGI::Carp::die Carp::shortmess \@_; } +sub carp { CGI::Carp::warn Carp::shortmess \@_; } +EOF + ; +} + +# We have to be ready to accept a filehandle as a reference +# or a string. +sub carpout { + my($in) = @_; + $in = $$in if ref($in); # compatability with Marc's method; + my($no) = fileno($in); + unless (defined($no)) { + my($package) = caller; + my($handle) = $in=~/[':]/ ? $in : "$package\:\:$in"; + $no = fileno($handle); + } + die "Invalid filehandle $in\n" unless $no; + + open(SAVEERR, ">&STDERR"); + open(STDERR, ">&$no") or + ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); +} + +# headers +sub fatalsToBrowser { + my($msg) = @_; + $msg=~s/>/>/g; + $msg=~s/</</g; + print STDOUT "Content-type: text/html\n\n"; + print STDOUT <<END; +<H1>Software error:</H1> +<CODE>$msg</CODE> +<P> +Please send mail to this site's webmaster for help. +END +} + +1; diff --git a/gnu/usr.bin/perl/lib/CGI/Fast.pm b/gnu/usr.bin/perl/lib/CGI/Fast.pm new file mode 100644 index 00000000000..03b54072c96 --- /dev/null +++ b/gnu/usr.bin/perl/lib/CGI/Fast.pm @@ -0,0 +1,173 @@ +package CGI::Fast; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +# You can run this file through either pod2man or pod2html to produce pretty +# documentation in manual or html file format (these utilities are part of the +# Perl 5 distribution). + +# Copyright 1995,1996, Lincoln D. Stein. All rights reserved. +# It may be used and modified freely, but I do request that this copyright +# notice remain attached to the file. You may modify this module as you +# wish, but if you redistribute a modified version, please attach a note +# listing the modifications you have made. + +# The most recent version and complete docs are available at: +# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html +# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ +$CGI::Fast::VERSION='1.00a'; + +use CGI; +use FCGI; +@ISA = ('CGI'); + +# workaround for known bug in libfcgi +while (($ignore) = each %ENV) { } + +# override the initialization behavior so that +# state is NOT maintained between invocations +sub save_request { + # no-op +} + +# New is slightly different in that it calls FCGI's +# accept() method. +sub new { + return undef unless FCGI::accept() >= 0; + my($self,@param) = @_; + return $CGI::Q = $self->SUPER::new(@param); +} + +1; + +=head1 NAME + +CGI::Fast - CGI Interface for Fast CGI + +=head1 SYNOPSIS + + use CGI::Fast qw(:standard); + $COUNTER = 0; + while (new CGI::Fast) { + print header; + print start_html("Fast CGI Rocks"); + print + h1("Fast CGI Rocks"), + "Invocation number ",b($COUNTER++), + " PID ",b($$),".", + hr; + print end_html; + } + +=head1 DESCRIPTION + +CGI::Fast is a subclass of the CGI object created by +CGI.pm. It is specialized to work well with the Open Market +FastCGI standard, which greatly speeds up CGI scripts by +turning them into persistently running server processes. Scripts +that perform time-consuming initialization processes, such as +loading large modules or opening persistent database connections, +will see large performance improvements. + +=head1 OTHER PIECES OF THE PUZZLE + +In order to use CGI::Fast you'll need a FastCGI-enabled Web +server. Open Market's server is FastCGI-savvy. There are also +freely redistributable FastCGI modules for NCSA httpd 1.5 and Apache. +FastCGI-enabling modules for Microsoft Internet Information Server and +Netscape Communications Server have been announced. + +In addition, you'll need a version of the Perl interpreter that has +been linked with the FastCGI I/O library. Precompiled binaries are +available for several platforms, including DEC Alpha, HP-UX and +SPARC/Solaris, or you can rebuild Perl from source with patches +provided in the FastCGI developer's kit. The FastCGI Perl interpreter +can be used in place of your normal Perl without ill consequences. + +You can find FastCGI modules for Apache and NCSA httpd, precompiled +Perl interpreters, and the FastCGI developer's kit all at URL: + + http://www.fastcgi.com/ + +=head1 WRITING FASTCGI PERL SCRIPTS + +FastCGI scripts are persistent: one or more copies of the script +are started up when the server initializes, and stay around until +the server exits or they die a natural death. After performing +whatever one-time initialization it needs, the script enters a +loop waiting for incoming connections, processing the request, and +waiting some more. + +A typical FastCGI script will look like this: + + #!/usr/local/bin/perl # must be a FastCGI version of perl! + use CGI::Fast; + &do_some_initialization(); + while ($q = new CGI::Fast) { + &process_request($q); + } + +Each time there's a new request, CGI::Fast returns a +CGI object to your loop. The rest of the time your script +waits in the call to new(). When the server requests that +your script be terminated, new() will return undef. You can +of course exit earlier if you choose. A new version of the +script will be respawned to take its place (this may be +necessary in order to avoid Perl memory leaks in long-running +scripts). + +CGI.pm's default CGI object mode also works. Just modify the loop +this way: + + while (new CGI::Fast) { + &process_request; + } + +Calls to header(), start_form(), etc. will all operate on the +current request. + +=head1 INSTALLING FASTCGI SCRIPTS + +See the FastCGI developer's kit documentation for full details. On +the Apache server, the following line must be added to srm.conf: + + AddType application/x-httpd-fcgi .fcgi + +FastCGI scripts must end in the extension .fcgi. For each script you +install, you must add something like the following to srm.conf: + + AppClass /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2 + +This instructs Apache to launch two copies of file_upload.fcgi at +startup time. + +=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS + +Any script that works correctly as a FastCGI script will also work +correctly when installed as a vanilla CGI script. However it will +not see any performance benefit. + +=head1 CAVEATS + +I haven't tested this very much. + +=head1 AUTHOR INFORMATION + +be used and modified freely, but I do request that this copyright +notice remain attached to the file. You may modify this module as you +wish, but if you redistribute a modified version, please attach a note +listing the modifications you have made. + +Address bug reports and comments to: +lstein@genome.wi.mit.edu + +=head1 BUGS + +This section intentionally left blank. + +=head1 SEE ALSO + +L<CGI::Carp>, L<CGI> + +=cut diff --git a/gnu/usr.bin/perl/lib/CGI/Push.pm b/gnu/usr.bin/perl/lib/CGI/Push.pm new file mode 100644 index 00000000000..4390d0383e6 --- /dev/null +++ b/gnu/usr.bin/perl/lib/CGI/Push.pm @@ -0,0 +1,239 @@ +package CGI::Push; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +# You can run this file through either pod2man or pod2html to produce pretty +# documentation in manual or html file format (these utilities are part of the +# Perl 5 distribution). + +# Copyright 1995,1996, Lincoln D. Stein. All rights reserved. +# It may be used and modified freely, but I do request that this copyright +# notice remain attached to the file. You may modify this module as you +# wish, but if you redistribute a modified version, please attach a note +# listing the modifications you have made. + +# The most recent version and complete docs are available at: +# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html +# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/ + +$CGI::Push::VERSION='1.00'; +use CGI; +@ISA = ('CGI'); + +# add do_push() to exported tags +push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push'); + +sub do_push { + my ($self,@p) = CGI::self_or_CGI(@_); + + # unbuffer output + $| = 1; + srand; + my ($random) = rand()*1E16; + my ($boundary) = "----------------------------------$random"; + + my (@header); + my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,@other) = + $self->rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p); + $type = 'text/html' unless $type; + $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE'; + $delay = 1 unless defined($delay); + + my(@o); + foreach (@other) { push(@o,split("=")); } + push(@o,'-Target'=>$target) if defined($target); + push(@o,'-Cookie'=>$cookie) if defined($cookie); + push(@o,'-Type'=>"multipart/x-mixed-replace; boundary=$boundary"); + push(@o,'-Server'=>"CGI.pm Push Module"); + push(@o,'-Status'=>'200 OK'); + push(@o,'-nph'=>1); + print $self->header(@o); + print "${boundary}$CGI::CRLF"; + + # now we enter a little loop + my @contents; + while (1) { + last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]); + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF"; + print @contents,"$CGI::CRLF"; + print "${boundary}$CGI::CRLF"; + do_sleep($delay) if $delay; + } + print "Content-type: ${type}$CGI::CRLF$CGI::CRLF", + &$last_page($self,++$COUNTER), + "$CGI::CRLF${boundary}$CGI::CRLF" + if $last_page && ref($last_page) eq 'CODE'; +} + +sub simple_counter { + my ($self,$count) = @_; + return ( + CGI->start_html("CGI::Push Default Counter"), + CGI->h1("CGI::Push Default Counter"), + "This page has been updated ",CGI->strong($count)," times.", + CGI->hr(), + CGI->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'), + CGI->end_html + ); +} + +sub do_sleep { + my $delay = shift; + if ( ($delay >= 1) && ($delay!~/\./) ){ + sleep($delay); + } else { + select(undef,undef,undef,$delay); + } +} + +1; + +=head1 NAME + +CGI::Push - Simple Interface to Server Push + +=head1 SYNOPSIS + + use CGI::Push qw(:standard); + + do_push(-next_page=>\&next_page, + -last_page=>\&last_page, + -delay=>0.5); + + sub next_page { + my($q,$counter) = @_; + return undef if $counter >= 10; + return start_html('Test'), + h1('Visible'),"\n", + "This page has been called ", strong($counter)," times", + end_html(); + } + + sub last_page { + my($q,$counter) = @_; + return start_html('Done'), + h1('Finished'), + strong($counter),' iterations.', + end_html; + } + +=head1 DESCRIPTION + +CGI::Push is a subclass of the CGI object created by CGI.pm. It is +specialized for server push operations, which allow you to create +animated pages whose content changes at regular intervals. + +You provide CGI::Push with a pointer to a subroutine that will draw +one page. Every time your subroutine is called, it generates a new +page. The contents of the page will be transmitted to the browser +in such a way that it will replace what was there beforehand. The +technique will work with HTML pages as well as with graphics files, +allowing you to create animated GIFs. + +=head1 USING CGI::Push + +CGI::Push adds one new method to the standard CGI suite, do_push(). +When you call this method, you pass it a reference to a subroutine +that is responsible for drawing each new page, an interval delay, and +an optional subroutine for drawing the last page. Other optional +parameters include most of those recognized by the CGI header() +method. + +You may call do_push() in the object oriented manner or not, as you +prefer: + + use CGI::Push; + $q = new CGI::Push; + $q->do_push(-next_page=>\&draw_a_page); + + -or- + + use CGI::Push qw(:standard); + do_push(-next_page=>\&draw_a_page); + +Parameters are as follows: + +=over 4 + +=item -next_page + + do_push(-next_page=>\&my_draw_routine); + +This required parameter points to a reference to a subroutine responsible for +drawing each new page. The subroutine should expect two parameters +consisting of the CGI object and a counter indicating the number +of times the subroutine has been called. It should return the +contents of the page as an B<array> of one or more items to print. +It can return a false value (or an empty array) in order to abort the +redrawing loop and print out the final page (if any) + + sub my_draw_routine { + my($q,$counter) = @_; + return undef if $counter > 100; + return start_html('testing'), + h1('testing'), + "This page called $counter times"; + } + +=item -last_page + +This optional parameter points to a reference to the subroutine +responsible for drawing the last page of the series. It is called +after the -next_page routine returns a false value. The subroutine +itself should have exactly the same calling conventions as the +-next_page routine. + +=item -type + +This optional parameter indicates the content type of each page. It +defaults to "text/html". Currently, server push of heterogeneous +document types is not supported. + +=item -delay + +This indicates the delay, in seconds, between frames. Smaller delays +refresh the page faster. Fractional values are allowed. + +B<If not specified, -delay will default to 1 second> + +=item -cookie, -target, -expires + +These have the same meaning as the like-named parameters in +CGI::header(). + +=back + +=head1 INSTALLING CGI::Push SCRIPTS + +Server push scripts B<must> be installed as no-parsed-header (NPH) +scripts in order to work correctly. On Unix systems, this is most +often accomplished by prefixing the script's name with "nph-". +Recognition of NPH scripts happens automatically with WebSTAR and +Microsoft IIS. Users of other servers should see their documentation +for help. + +=head1 CAVEATS + +This is a new module. It hasn't been extensively tested. + +=head1 AUTHOR INFORMATION + +be used and modified freely, but I do request that this copyright +notice remain attached to the file. You may modify this module as you +wish, but if you redistribute a modified version, please attach a note +listing the modifications you have made. + +Address bug reports and comments to: +lstein@genome.wi.mit.edu + +=head1 BUGS + +This section intentionally left blank. + +=head1 SEE ALSO + +L<CGI::Carp>, L<CGI> + +=cut + diff --git a/gnu/usr.bin/perl/lib/CGI/Switch.pm b/gnu/usr.bin/perl/lib/CGI/Switch.pm new file mode 100644 index 00000000000..420fff7643c --- /dev/null +++ b/gnu/usr.bin/perl/lib/CGI/Switch.pm @@ -0,0 +1,78 @@ +package CGI::Switch; +use Carp; +use strict; +use vars qw($VERSION @Pref); +$VERSION = '0.05'; +@Pref = qw(CGI::Apache CGI); #default + +sub import { + my($self,@arg) = @_; + @Pref = @arg if @arg; +} + +sub new { + shift; + my($file,$pack); + for $pack (@Pref) { + ($file = $pack) =~ s|::|/|g; + eval { require "$file.pm"; }; + if ($@) { +#XXX warn $@; + next; + } else { +#XXX warn "Going to try $pack\->new\n"; + my $obj; + eval {$obj = $pack->new(@_)}; + if ($@) { +#XXX warn $@; + } else { + return $obj; + } + } + } + Carp::croak "Couldn't load+construct any of @Pref\n"; +} + +# there's a trick in Lincoln's package that determines the calling +# package. The reason is to have a filehandle with the same name as +# the filename. To tell this trick that we are not the calling +# package we have to follow this dirty convention. It's a questionable +# trick imho, but for now I want to have something working +sub isaCGI { 1 } + +1; +__END__ + +=head1 NAME + +CGI::Switch - Try more than one constructors and return the first object available + +=head1 SYNOPSIS + + + use CGISwitch; + + -or- + + use CGI::Switch This, That, CGI::XA, Foo, Bar, CGI; + + my $q = new CGI::Switch; + +=head1 DESCRIPTION + +Per default the new() method tries to call new() in the three packages +Apache::CGI, CGI::XA, and CGI. It returns the first CGI object it +succeeds with. + +The import method allows you to set up the default order of the +modules to be tested. + +=head1 SEE ALSO + +perl(1), Apache(3), CGI(3), CGI::XA(3) + +=head1 AUTHOR + +Andreas König E<lt>a.koenig@mind.deE<gt> + +=cut diff --git a/gnu/usr.bin/perl/lib/CPAN.pm b/gnu/usr.bin/perl/lib/CPAN.pm new file mode 100644 index 00000000000..2b0f6cce5dd --- /dev/null +++ b/gnu/usr.bin/perl/lib/CPAN.pm @@ -0,0 +1,3985 @@ +package CPAN; +use vars qw{$Try_autoload $Revision + $META $Signal $Cwd $End + $Suppress_readline %Dontload + $Frontend + }; + +$VERSION = '1.3102'; + +# $Id: CPAN.pm,v 1.1 1997/11/30 07:56:39 millert Exp $ + +# only used during development: +$Revision = ""; +# $Revision = "[".substr(q$Revision: 1.1 $, 10)."]"; + +use Carp (); +use Config (); +use Cwd (); +use DirHandle; +use Exporter (); +use ExtUtils::MakeMaker (); +use File::Basename (); +use File::Copy (); +use File::Find; +use File::Path (); +use FileHandle (); +use Safe (); +use Text::ParseWords (); +use Text::Wrap; + +END { $End++; &cleanup; } + +%CPAN::DEBUG = qw( + CPAN 1 + Index 2 + InfoObj 4 + Author 8 + Distribution 16 + Bundle 32 + Module 64 + CacheMgr 128 + Complete 256 + FTP 512 + Shell 1024 + Eval 2048 + Config 4096 + ); + +$CPAN::DEBUG ||= 0; +$CPAN::Signal ||= 0; +$CPAN::Frontend ||= "CPAN::Shell"; + +package CPAN; +use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term); +use strict qw(vars); + +@CPAN::ISA = qw(CPAN::Debug Exporter MM); # MM will go away + # soonish. Already version + # 1.29 doesn't rely on + # catfile and catdir being + # available via + # inheritance. Anything else + # in danger? + +@EXPORT = qw( + autobundle bundle expand force get + install make readme recompile shell test clean + ); + +#-> sub CPAN::AUTOLOAD ; +sub AUTOLOAD { + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + my(%EXPORT); + @EXPORT{@EXPORT} = ''; + if (exists $EXPORT{$l}){ + CPAN::Shell->$l(@_); + } else { + my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); + if ($ok) { + goto &$AUTOLOAD; +# } else { +# $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD"); + } + $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }. + qq{Type ? for help. +}); + } +} + +#-> sub CPAN::shell ; +sub shell { + $Suppress_readline ||= ! -t STDIN; + + my $prompt = "cpan> "; + local($^W) = 1; + unless ($Suppress_readline) { + require Term::ReadLine; +# import Term::ReadLine; + $term = Term::ReadLine->new('CPAN Monitor'); + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } + + no strict; + $META->checklock(); + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $cwd = CPAN->$getcwd(); + my $rl_avail = $Suppress_readline ? "suppressed" : + ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : + "available (try ``install Bundle::CPAN'')"; + + $CPAN::Frontend->myprint( + qq{ +cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision) +ReadLine support $rl_avail + +}) unless $CPAN::Config->{'inhibit_startup_message'} ; + my($continuation) = ""; + while () { + if ($Suppress_readline) { + print $prompt; + last unless defined ($_ = <> ); + chomp; + } else { + last unless defined ($_ = $term->readline($prompt)); + } + $_ = "$continuation$_" if $continuation; + s/^\s+//; + next if /^$/; + $_ = 'h' if $_ eq '?'; + if (/^q(?:uit)?$/i) { + last; + } elsif (s/\\$//s) { + chomp; + $continuation = $_; + $prompt = " > "; + } elsif (/^\!/) { + s/^\!//; + my($eval) = $_; + package CPAN::Eval; + use vars qw($import_done); + CPAN->import(':DEFAULT') unless $import_done++; + CPAN->debug("eval[$eval]") if $CPAN::DEBUG; + eval($eval); + warn $@ if $@; + $continuation = ""; + $prompt = "cpan> "; + } elsif (/./) { + my(@line); + if ($] < 5.00322) { # parsewords had a bug until recently + @line = split; + } else { + eval { @line = Text::ParseWords::shellwords($_) }; + warn($@), next if $@; + } + $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; + my $command = shift @line; + eval { CPAN::Shell->$command(@line) }; + warn $@ if $@; + chdir $cwd; + $CPAN::Frontend->myprint("\n"); + $continuation = ""; + $prompt = "cpan> "; + } + } continue { + &cleanup, $CPAN::Frontend->mydie("Goodbye\n") if $Signal; + } +} + +package CPAN::CacheMgr; +use vars qw($Du); +@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); +use File::Find; + +package CPAN::Config; +import ExtUtils::MakeMaker 'neatvalue'; +use vars qw(%can $dot_cpan); + +%can = ( + 'commit' => "Commit changes to disk", + 'defaults' => "Reload defaults from disk", + 'init' => "Interactive setting of all options", +); + +package CPAN::FTP; +use vars qw($Ua $Thesite $Themethod); +@CPAN::FTP::ISA = qw(CPAN::Debug); + +package CPAN::Complete; +@CPAN::Complete::ISA = qw(CPAN::Debug); + +package CPAN::Index; +use vars qw($last_time $date_of_03); +@CPAN::Index::ISA = qw(CPAN::Debug); +$last_time ||= 0; +$date_of_03 ||= 0; + +package CPAN::InfoObj; +@CPAN::InfoObj::ISA = qw(CPAN::Debug); + +package CPAN::Author; +@CPAN::Author::ISA = qw(CPAN::InfoObj); + +package CPAN::Distribution; +@CPAN::Distribution::ISA = qw(CPAN::InfoObj); + +package CPAN::Bundle; +@CPAN::Bundle::ISA = qw(CPAN::Module); + +package CPAN::Module; +@CPAN::Module::ISA = qw(CPAN::InfoObj); + +package CPAN::Shell; +use vars qw($AUTOLOAD $redef @ISA); +@CPAN::Shell::ISA = qw(CPAN::Debug); + +#-> sub CPAN::Shell::AUTOLOAD ; +sub AUTOLOAD { + my($autoload) = $AUTOLOAD; + my $class = shift(@_); + $autoload =~ s/.*:://; + if ($autoload =~ /^w/) { + if ($CPAN::META->has_inst('CPAN::WAIT')) { + CPAN::WAIT->$autoload(@_); + } else { + $CPAN::Frontend->mywarn(qq{ +Commands starting with "w" require CPAN::WAIT to be installed. +Please consider installing CPAN::WAIT to use the fulltext index. +For this you just need to type + install CPAN::WAIT +}); + } + } else { + my $ok = CPAN::Shell->try_dot_al($AUTOLOAD); + if ($ok) { + goto &$AUTOLOAD; +# } else { +# $CPAN::Frontend->mywarn("Could not autoload $autoload"); + } + $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }. + qq{Type ? for help. +}); + } +} + +#-> CPAN::Shell::try_dot_al +sub try_dot_al { + my($class,$autoload) = @_; + return unless $CPAN::Try_autoload; + # I don't see how to re-use that from the AutoLoader... + my($name,$ok); + # Braces used to preserve $1 et al. + { + my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/; + $pkg =~ s|::|/|g; + if (defined($name=$INC{"$pkg.pm"})) + { + $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|; + $name = undef unless (-r $name); + } + unless (defined $name) + { + $name = "auto/$autoload.al"; + $name =~ s|::|/|g; + } + } + my $save = $@; + eval {local $SIG{__DIE__};require $name}; + if ($@) { + if (substr($autoload,-9) eq '::DESTROY') { + *$autoload = sub {}; + $ok = 1; + } else { + if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval {local $SIG{__DIE__};require $name}; + } + if ($@){ + $@ =~ s/ at .*\n//; + Carp::croak $@; + } else { + $ok = 1; + } + } + } else { + $ok = 1; + } + $@ = $save; +# my $lm = Carp::longmess(); +# warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug + return $ok; +} + +#### autoloader is experimental +#### to try it we have to set $Try_autoload and uncomment +#### the use statement and uncomment the __END__ below +#### You also need AutoSplit 1.01 available. MakeMaker will +#### then build CPAN with all the AutoLoad stuff. +# use AutoLoader; +# $Try_autoload = 1; + +if ($CPAN::Try_autoload) { + my $p; + for $p (qw( + CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete + CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP + CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module + )) { + *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD; + } +} + + +package CPAN; + +$META ||= CPAN->new; # In case we reeval ourselves we + # need a || + +# Do this after you have set up the whole inheritance +CPAN::Config->load unless defined $CPAN::No_Config_is_ok; + +1; + +# __END__ # uncomment this and AutoSplit version 1.01 will split it + +#-> sub CPAN::autobundle ; +sub autobundle; +#-> sub CPAN::bundle ; +sub bundle; +#-> sub CPAN::expand ; +sub expand; +#-> sub CPAN::force ; +sub force; +#-> sub CPAN::install ; +sub install; +#-> sub CPAN::make ; +sub make; +#-> sub CPAN::clean ; +sub clean; +#-> sub CPAN::test ; +sub test; + +#-> sub CPAN::all ; +sub all { + my($mgr,$class) = @_; + CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; + CPAN::Index->reload; + values %{ $META->{$class} }; +} + +# Called by shell, not in batch mode. Not clean XXX +#-> sub CPAN::checklock ; +sub checklock { + my($self) = @_; + my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock"); + if (-f $lockfile && -M _ > 0) { + my $fh = FileHandle->new($lockfile); + my $other = <$fh>; + $fh->close; + if (defined $other && $other) { + chomp $other; + return if $$==$other; # should never happen + $CPAN::Frontend->mywarn( + qq{ +There seems to be running another CPAN process ($other). Contacting... +}); + if (kill 0, $other) { + $CPAN::Frontend->mydie(qq{Other job is running. +You may want to kill it and delete the lockfile, maybe. On UNIX try: + kill $other + rm $lockfile +}); + } elsif (-w $lockfile) { + my($ans) = + ExtUtils::MakeMaker::prompt + (qq{Other job not responding. Shall I overwrite }. + qq{the lockfile? (Y/N)},"y"); + $CPAN::Frontend->myexit("Ok, bye\n") + unless $ans =~ /^y/i; + } else { + Carp::croak( + qq{Lockfile $lockfile not writeable by you. }. + qq{Cannot proceed.\n}. + qq{ On UNIX try:\n}. + qq{ rm $lockfile\n}. + qq{ and then rerun us.\n} + ); + } + } + } + File::Path::mkpath($CPAN::Config->{cpan_home}); + my $fh; + unless ($fh = FileHandle->new(">$lockfile")) { + if ($! =~ /Permission/) { + my $incc = $INC{'CPAN/Config.pm'}; + my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm'); + $CPAN::Frontend->myprint(qq{ + +Your configuration suggests that CPAN.pm should use a working +directory of + $CPAN::Config->{cpan_home} +Unfortunately we could not create the lock file + $lockfile +due to permission problems. + +Please make sure that the configuration variable + \$CPAN::Config->{cpan_home} +points to a directory where you can write a .lock file. You can set +this variable in either + $incc +or + $myincc + +}); + } + $CPAN::Frontend->mydie("Could not open >$lockfile: $!"); + } + $fh->print($$, "\n"); + $self->{LOCK} = $lockfile; + $fh->close; + $SIG{'TERM'} = sub { + &cleanup; + $CPAN::Frontend->mydie("Got SIGTERM, leaving"); + }; + $SIG{'INT'} = sub { + my $s = $Signal == 2 ? "a second" : "another"; + &cleanup, $CPAN::Frontend->mydie("Got $s SIGINT") if $Signal; + $Signal = 1; + }; + $SIG{'__DIE__'} = \&cleanup; + $self->debug("Signal handler set.") if $CPAN::DEBUG; +} + +#-> sub CPAN::DESTROY ; +sub DESTROY { + &cleanup; # need an eval? +} + +#-> sub CPAN::cwd ; +sub cwd {Cwd::cwd();} + +#-> sub CPAN::getcwd ; +sub getcwd {Cwd::getcwd();} + +#-> sub CPAN::exists ; +sub exists { + my($mgr,$class,$id) = @_; + CPAN::Index->reload; + ### Carp::croak "exists called without class argument" unless $class; + $id ||= ""; + exists $META->{$class}{$id}; +} + +#-> sub CPAN::has_inst +sub has_inst { + my($self,$mod,$message) = @_; + Carp::croak("CPAN->has_inst() called without an argument") + unless defined $mod; + if (defined $message && $message eq "no") { + $Dontload{$mod}||=1; + return 0; + } elsif (exists $Dontload{$mod}) { + return 0; + } + my $file = $mod; + my $obj; + $file =~ s|::|/|g; + $file =~ s|/|\\|g if $^O eq 'MSWin32'; + $file .= ".pm"; + if ($INC{$file}) { +# warn "$file in %INC"; #debug + return 1; + } elsif (eval { require $file }) { + # eval is good: if we haven't yet read the database it's + # perfect and if we have installed the module in the meantime, + # it tries again. The second require is only a NOOP returning + # 1 if we had success, otherwise it's retrying + $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n"); + if ($mod eq "CPAN::WAIT") { + push @CPAN::Shell::ISA, CPAN::WAIT; + } + return 1; + } elsif ($mod eq "Net::FTP") { + warn qq{ + Please, install Net::FTP as soon as possible. CPAN.pm installs it for you + if you just type + install Bundle::libnet + +}; + sleep 2; + } elsif ($mod eq "MD5"){ + $CPAN::Frontend->myprint(qq{ + CPAN: MD5 security checks disabled because MD5 not installed. + Please consider installing the MD5 module. + +}); + sleep 2; + } + return 0; +} + +#-> sub CPAN::instance ; +sub instance { + my($mgr,$class,$id) = @_; + CPAN::Index->reload; + $id ||= ""; + $META->{$class}{$id} ||= $class->new(ID => $id ); +} + +#-> sub CPAN::new ; +sub new { + bless {}, shift; +} + +#-> sub CPAN::cleanup ; +sub cleanup { + local $SIG{__DIE__} = ''; + my $i = 0; my $ineval = 0; my $sub; + while ((undef,undef,undef,$sub) = caller(++$i)) { + $ineval = 1, last if $sub eq '(eval)'; + } + return if $ineval && !$End; + return unless defined $META->{'LOCK'}; + return unless -f $META->{'LOCK'}; + unlink $META->{'LOCK'}; + $CPAN::Frontend->mywarn("Lockfile removed.\n"); +} + +package CPAN::CacheMgr; + +#-> sub CPAN::CacheMgr::as_string ; +sub as_string { + eval { require Data::Dumper }; + if ($@) { + return shift->SUPER::as_string; + } else { + return Data::Dumper::Dumper(shift); + } +} + +#-> sub CPAN::CacheMgr::cachesize ; +sub cachesize { + shift->{DU}; +} + +# sub check { +# my($self,@dirs) = @_; +# return unless -d $self->{ID}; +# my $dir; +# @dirs = $self->dirs unless @dirs; +# for $dir (@dirs) { +# $self->disk_usage($dir); +# } +# } + +#-> sub CPAN::CacheMgr::clean_cache ; +#=# sub clean_cache { +#=# my $self = shift; +#=# my $dir; +#=# while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) { +#=# $self->force_clean_cache($dir); +#=# } +#=# $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG; +#=# } + +#-> sub CPAN::CacheMgr::dir ; +sub dir { + shift->{ID}; +} + +#-> sub CPAN::CacheMgr::entries ; +sub entries { + my($self,$dir) = @_; + return unless defined $dir; + $self->debug("reading dir[$dir]") if $CPAN::DEBUG; + $dir ||= $self->{ID}; + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my($cwd) = CPAN->$getcwd(); + chdir $dir or Carp::croak("Can't chdir to $dir: $!"); + my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!"); + my(@entries); + for ($dh->read) { + next if $_ eq "." || $_ eq ".."; + if (-f $_) { + push @entries, MM->catfile($dir,$_); + } elsif (-d _) { + push @entries, MM->catdir($dir,$_); + } else { + $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n"); + } + } + chdir $cwd or Carp::croak("Can't chdir to $cwd: $!"); + sort { -M $b <=> -M $a} @entries; +} + +#-> sub CPAN::CacheMgr::disk_usage ; +sub disk_usage { + my($self,$dir) = @_; +# if (! defined $dir or $dir eq "") { +# $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG; +# return; +# } + return if $self->{SIZE}{$dir}; + local($Du) = 0; + find( + sub { + return if -l $_; + $Du += -s _; + }, + $dir + ); + $self->{SIZE}{$dir} = $Du/1024/1024; + push @{$self->{FIFO}}, $dir; + $self->debug("measured $dir is $Du") if $CPAN::DEBUG; + $self->{DU} += $Du/1024/1024; + if ($self->{DU} > $self->{'MAX'} ) { + my($toremove) = shift @{$self->{FIFO}}; + $CPAN::Frontend->myprint(sprintf( + "...Hold on a sec... ". + "cleaning from cache ". + "(%.1f>%.1f MB): $toremove\n", + $self->{DU}, $self->{'MAX'}) + ); + $self->force_clean_cache($toremove); + } + $self->{DU}; +} + +#-> sub CPAN::CacheMgr::force_clean_cache ; +sub force_clean_cache { + my($self,$dir) = @_; + $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}") + if $CPAN::DEBUG; + File::Path::rmtree($dir); + $self->{DU} -= $self->{SIZE}{$dir}; + delete $self->{SIZE}{$dir}; +} + +#-> sub CPAN::CacheMgr::new ; +sub new { + my $class = shift; + my $time = time; + my($debug,$t2); + $debug = ""; + my $self = { + ID => $CPAN::Config->{'build_dir'}, + MAX => $CPAN::Config->{'build_cache'}, + DU => 0 + }; + File::Path::mkpath($self->{ID}); + my $dh = DirHandle->new($self->{ID}); + bless $self, $class; + $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG; + my $e; + for $e ($self->entries) { + next if $e eq ".." || $e eq "."; + $self->disk_usage($e); + } + $t2 = time; + $debug .= "timing of CacheMgr->new: ".($t2 - $time); + $time = $t2; + CPAN->debug($debug) if $CPAN::DEBUG; + $self; +} + +package CPAN::Debug; + +#-> sub CPAN::Debug::debug ; +sub debug { + my($self,$arg) = @_; + my($caller,$func,$line,@rest) = caller(1); # caller(0) eg + # Complete, caller(1) + # eg readline + ($caller) = caller(0); + $caller =~ s/.*:://; + $arg = "" unless defined $arg; + my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest; + if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){ + if ($arg and ref $arg) { + eval { require Data::Dumper }; + if ($@) { + $CPAN::Frontend->myprint($arg->as_string); + } else { + $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg)); + } + } else { + $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n"); + } + } +} + +package CPAN::Config; + +#-> sub CPAN::Config::edit ; +sub edit { + my($class,@args) = @_; + return unless @args; + CPAN->debug("class[$class]args[".join(" | ",@args)."]"); + my($o,$str,$func,$args,$key_exists); + $o = shift @args; + if($can{$o}) { + $class->$o(@args); + return 1; + } else { + if (ref($CPAN::Config->{$o}) eq ARRAY) { + $func = shift @args; + $func ||= ""; + # Let's avoid eval, it's easier to comprehend without. + if ($func eq "push") { + push @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "pop") { + pop @{$CPAN::Config->{$o}}; + } elsif ($func eq "shift") { + shift @{$CPAN::Config->{$o}}; + } elsif ($func eq "unshift") { + unshift @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "splice") { + splice @{$CPAN::Config->{$o}}, @args; + } elsif (@args) { + $CPAN::Config->{$o} = [@args]; + } else { + $CPAN::Frontend->myprint( + join "", + " $o ", + ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}), + "\n" + ); + } + } else { + $CPAN::Config->{$o} = $args[0] if defined $args[0]; + $CPAN::Frontend->myprint(" $o " . + (defined $CPAN::Config->{$o} ? + $CPAN::Config->{$o} : "UNDEFINED")); + } + } +} + +#-> sub CPAN::Config::commit ; +sub commit { + my($self,$configpm) = @_; + unless (defined $configpm){ + $configpm ||= $INC{"CPAN/MyConfig.pm"}; + $configpm ||= $INC{"CPAN/Config.pm"}; + $configpm || Carp::confess(qq{ +CPAN::Config::commit called without an argument. +Please specify a filename where to save the configuration or try +"o conf init" to have an interactive course through configing. +}); + } + my($mode); + if (-f $configpm) { + $mode = (stat $configpm)[2]; + if ($mode && ! -w _) { + Carp::confess("$configpm is not writable"); + } + } + + my $msg = <<EOF unless $configpm =~ /MyConfig/; + +# This is CPAN.pm's systemwide configuration file. This file provides +# defaults for users, and the values can be changed in a per-user +# configuration file. The user-config file is being looked for as +# ~/.cpan/CPAN/MyConfig.pm. + +EOF + $msg ||= "\n"; + my($fh) = FileHandle->new; + open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!"; + $fh->print(qq[$msg\$CPAN::Config = \{\n]); + foreach (sort keys %$CPAN::Config) { + $fh->print( + " '$_' => ", + ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), + ",\n" + ); + } + + $fh->print("};\n1;\n__END__\n"); + close $fh; + + #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); + #chmod $mode, $configpm; +###why was that so? $self->defaults; + $CPAN::Frontend->myprint("commit: wrote $configpm\n"); + 1; +} + +*default = \&defaults; +#-> sub CPAN::Config::defaults ; +sub defaults { + my($self) = @_; + $self->unload; + $self->load; + 1; +} + +sub init { + my($self) = @_; + undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to + # have the least + # important + # variable + # undefined + $self->load; + 1; +} + +#-> sub CPAN::Config::load ; +sub load { + my($self) = shift; + my(@miss); + eval {require CPAN::Config;}; # We eval because of some + # MakeMaker problems + unshift @INC, MM->catdir($ENV{HOME},".cpan") unless $dot_cpan++; + eval {require CPAN::MyConfig;}; # where you can override + # system wide settings + return unless @miss = $self->not_loaded; + # XXX better check for arrayrefs too + require CPAN::FirstTime; + my($configpm,$fh,$redo,$theycalled); + $redo ||= ""; + $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message'; + if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { + $configpm = $INC{"CPAN/Config.pm"}; + $redo++; + } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { + $configpm = $INC{"CPAN/MyConfig.pm"}; + $redo++; + } else { + my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); + my($configpmdir) = MM->catdir($path_to_cpan,"CPAN"); + my($configpmtest) = MM->catfile($configpmdir,"Config.pm"); + if (-d $configpmdir or File::Path::mkpath($configpmdir)) { + if (-w $configpmtest) { + $configpm = $configpmtest; + } elsif (-w $configpmdir) { + #_#_# following code dumped core on me with 5.003_11, a.k. + unlink "$configpmtest.bak" if -f "$configpmtest.bak"; + rename $configpmtest, "$configpmtest.bak" if -f $configpmtest; + my $fh = FileHandle->new; + if ($fh->open(">$configpmtest")) { + $fh->print("1;\n"); + $configpm = $configpmtest; + } else { + # Should never happen + Carp::confess("Cannot open >$configpmtest"); + } + } + } + unless ($configpm) { + $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN"); + File::Path::mkpath($configpmdir); + $configpmtest = MM->catfile($configpmdir,"MyConfig.pm"); + if (-w $configpmtest) { + $configpm = $configpmtest; + } elsif (-w $configpmdir) { + #_#_# following code dumped core on me with 5.003_11, a.k. + my $fh = FileHandle->new; + if ($fh->open(">$configpmtest")) { + $fh->print("1;\n"); + $configpm = $configpmtest; + } else { + # Should never happen + Carp::confess("Cannot open >$configpmtest"); + } + } else { + Carp::confess(qq{WARNING: CPAN.pm is unable to }. + qq{create a configuration file.}); + } + } + } + local($") = ", "; + $CPAN::Frontend->myprint(qq{ +We have to reconfigure CPAN.pm due to following uninitialized parameters: + +@miss +}) if $redo && ! $theycalled; + $CPAN::Frontend->myprint(qq{ +$configpm initialized. +}); + sleep 2; + CPAN::FirstTime::init($configpm); +} + +#-> sub CPAN::Config::not_loaded ; +sub not_loaded { + my(@miss); + for (qw( + cpan_home keep_source_where build_dir build_cache index_expire + gzip tar unzip make pager makepl_arg make_arg make_install_arg + urllist inhibit_startup_message ftp_proxy http_proxy no_proxy + )) { + push @miss, $_ unless defined $CPAN::Config->{$_}; + } + return @miss; +} + +#-> sub CPAN::Config::unload ; +sub unload { + delete $INC{'CPAN/MyConfig.pm'}; + delete $INC{'CPAN/Config.pm'}; +} + +*h = \&help; +#-> sub CPAN::Config::help ; +sub help { + $CPAN::Frontend->myprint(qq{ +Known options: + defaults reload default config values from disk + commit commit session changes to disk + init go through a dialog to set all parameters + +You may edit key values in the follow fashion: + + o conf build_cache 15 + + o conf build_dir "/foo/bar" + + o conf urllist shift + + o conf urllist unshift ftp://ftp.foo.bar/ + +}); + undef; #don't reprint CPAN::Config +} + +#-> sub CPAN::Config::cpl ; +sub cpl { + my($word,$line,$pos) = @_; + $word ||= ""; + CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + my(@words) = split " ", substr($line,0,$pos+1); + if ( + $words[2] =~ /list$/ && @words == 3 + || + $words[2] =~ /list$/ && @words == 4 && length($word) + ) { + return grep /^\Q$word\E/, qw(splice shift unshift pop push); + } elsif (@words >= 4) { + return (); + } + my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config); + return grep /^\Q$word\E/, @o_conf; +} + +package CPAN::Shell; + +#-> sub CPAN::Shell::h ; +sub h { + my($class,$about) = @_; + if (defined $about) { + $CPAN::Frontend->myprint("Detailed help not yet implemented\n"); + } else { + $CPAN::Frontend->myprint(q{ +command arguments description +a string authors +b or display bundles +d /regex/ info distributions +m or about modules +i none anything of above + +r as reinstall recommendations +u above uninstalled distributions +See manpage for autobundle, recompile, force, look, etc. + +make make +test modules, make test (implies make) +install dists, bundles, make install (implies test) +clean "r" or "u" make clean +readme display the README file + +reload index|cpan load most recent indices/CPAN.pm +h or ? display this menu +o various set and query options +! perl-code eval a perl command +q quit the shell subroutine +}); + } +} + +#-> sub CPAN::Shell::a ; +sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));} +#-> sub CPAN::Shell::b ; +sub b { + my($self,@which) = @_; + CPAN->debug("which[@which]") if $CPAN::DEBUG; + my($incdir,$bdir,$dh); + foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { + $bdir = MM->catdir($incdir,"Bundle"); + if ($dh = DirHandle->new($bdir)) { # may fail + my($entry); + for $entry ($dh->read) { + next if -d MM->catdir($bdir,$entry); + next unless $entry =~ s/\.pm$//; + $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry"); + } + } + } + $CPAN::Frontend->myprint($self->format_result('Bundle',@which)); +} +#-> sub CPAN::Shell::d ; +sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));} +#-> sub CPAN::Shell::m ; +sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));} + +#-> sub CPAN::Shell::i ; +sub i { + my($self) = shift; + my(@args) = @_; + my(@type,$type,@m); + @type = qw/Author Bundle Distribution Module/; + @args = '/./' unless @args; + my(@result); + for $type (@type) { + push @result, $self->expand($type,@args); + } + my $result = @result == 1 ? + $result[0]->as_string : + join "", map {$_->as_glimpse} @result; + $result ||= "No objects found of any type for argument @args\n"; + $CPAN::Frontend->myprint($result); +} + +#-> sub CPAN::Shell::o ; +sub o { + my($self,$o_type,@o_what) = @_; + $o_type ||= ""; + CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n"); + if ($o_type eq 'conf') { + shift @o_what if @o_what && $o_what[0] eq 'help'; + if (!@o_what) { + my($k,$v); + $CPAN::Frontend->myprint("CPAN::Config options:\n"); + for $k (sort keys %CPAN::Config::can) { + $v = $CPAN::Config::can{$k}; + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); + } + $CPAN::Frontend->myprint("\n"); + for $k (sort keys %$CPAN::Config) { + $v = $CPAN::Config->{$k}; + if (ref $v) { + $CPAN::Frontend->myprint( + join( + "", + sprintf( + " %-18s\n", + $k + ), + map {"\t$_\n"} @{$v} + ) + ); + } else { + $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v); + } + } + $CPAN::Frontend->myprint("\n"); + } elsif (!CPAN::Config->edit(@o_what)) { + $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]); + } + } elsif ($o_type eq 'debug') { + my(%valid); + @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i; + if (@o_what) { + while (@o_what) { + my($what) = shift @o_what; + if ( exists $CPAN::DEBUG{$what} ) { + $CPAN::DEBUG |= $CPAN::DEBUG{$what}; + } elsif ($what =~ /^\d/) { + $CPAN::DEBUG = $what; + } elsif (lc $what eq 'all') { + my($max) = 0; + for (values %CPAN::DEBUG) { + $max += $_; + } + $CPAN::DEBUG = $max; + } else { + my($known) = 0; + for (keys %CPAN::DEBUG) { + next unless lc($_) eq lc($what); + $CPAN::DEBUG |= $CPAN::DEBUG{$_}; + $known = 1; + } + $CPAN::Frontend->myprint("unknown argument [$what]\n") + unless $known; + } + } + } else { + $CPAN::Frontend->myprint("Valid options for debug are ". + join(", ",sort(keys %CPAN::DEBUG), 'all'). + qq{ or a number. Completion works on the options. }. + qq{Case is ignored.\n\n}); + } + if ($CPAN::DEBUG) { + $CPAN::Frontend->myprint("Options set for debugging:\n"); + my($k,$v); + for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { + $v = $CPAN::DEBUG{$k}; + $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG; + } + } else { + $CPAN::Frontend->myprint("Debugging turned off completely.\n"); + } + } else { + $CPAN::Frontend->myprint(qq{ +Known options: + conf set or get configuration variables + debug set or get debugging options +}); + } +} + +#-> sub CPAN::Shell::reload ; +sub reload { + my($self,$command,@arg) = @_; + $command ||= ""; + $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; + if ($command =~ /cpan/i) { + CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG; + my $fh = FileHandle->new($INC{'CPAN.pm'}); + local($/); + undef $/; + $redef = 0; + local($SIG{__WARN__}) + = sub { + if ( $_[0] =~ /Subroutine \w+ redefined/ ) { + ++$redef; + local($|) = 1; + $CPAN::Frontend->myprint("."); + return; + } + warn @_; + }; + eval <$fh>; + warn $@ if $@; + $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); + } elsif ($command =~ /index/) { + CPAN::Index->force_reload; + } else { + $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file +index re-reads the index files +}); + } +} + +#-> sub CPAN::Shell::_binary_extensions ; +sub _binary_extensions { + my($self) = shift @_; + my(@result,$module,%seen,%need,$headerdone); + my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$}; + for $module ($self->expand('Module','/./')) { + my $file = $module->cpan_file; + next if $file eq "N/A"; + next if $file =~ /^Contact Author/; + next if $file =~ / $isaperl /xo; + next unless $module->xs_file; + local($|) = 1; + $CPAN::Frontend->myprint("."); + push @result, $module; + } +# print join " | ", @result; + $CPAN::Frontend->myprint("\n"); + return @result; +} + +#-> sub CPAN::Shell::recompile ; +sub recompile { + my($self) = shift @_; + my($module,@module,$cpan_file,%dist); + @module = $self->_binary_extensions(); + for $module (@module){ # we force now and compile later, so we + # don't do it twice + $cpan_file = $module->cpan_file; + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->force; + $dist{$cpan_file}++; + } + for $cpan_file (sort keys %dist) { + $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n"); + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->install; + $CPAN::Signal = 0; # it's tempting to reset Signal, so we can + # stop a package from recompiling, + # e.g. IO-1.12 when we have perl5.003_10 + } +} + +#-> sub CPAN::Shell::_u_r_common ; +sub _u_r_common { + my($self) = shift @_; + my($what) = shift @_; + CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG; + Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what; + Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/; + my(@args) = @_; + @args = '/./' unless @args; + my(@result,$module,%seen,%need,$headerdone, + $version_undefs,$version_zeroes); + $version_undefs = $version_zeroes = 0; + my $sprintf = "%-25s %9s %9s %s\n"; + for $module ($self->expand('Module',@args)) { + my $file = $module->cpan_file; + next unless defined $file; # ?? + my($latest) = $module->cpan_version; + my($inst_file) = $module->inst_file; + my($have); + if ($inst_file){ + if ($what eq "a") { + $have = $module->inst_version; + } elsif ($what eq "r") { + $have = $module->inst_version; + local($^W) = 0; + if ($have eq "undef"){ + $version_undefs++; + } elsif ($have == 0){ + $version_zeroes++; + } + next if $have >= $latest; +# to be pedantic we should probably say: +# && !($have eq "undef" && $latest ne "undef" && $latest gt ""); +# to catch the case where CPAN has a version 0 and we have a version undef + } elsif ($what eq "u") { + next; + } + } else { + if ($what eq "a") { + next; + } elsif ($what eq "r") { + next; + } elsif ($what eq "u") { + $have = "-"; + } + } + return if $CPAN::Signal; # this is sometimes lengthy + $seen{$file} ||= 0; + if ($what eq "a") { + push @result, sprintf "%s %s\n", $module->id, $have; + } elsif ($what eq "r") { + push @result, $module->id; + next if $seen{$file}++; + } elsif ($what eq "u") { + push @result, $module->id; + next if $seen{$file}++; + next if $file =~ /^Contact/; + } + unless ($headerdone++){ + $CPAN::Frontend->myprint("\n"); + $CPAN::Frontend->myprint(sprintf( + $sprintf, + "Package namespace", + "installed", + "latest", + "in CPAN file" + )); + } + $latest = substr($latest,0,8) if length($latest) > 8; + $have = substr($have,0,8) if length($have) > 8; + $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file); + $need{$module->id}++; + } + unless (%need) { + if ($what eq "u") { + $CPAN::Frontend->myprint("No modules found for @args\n"); + } elsif ($what eq "r") { + $CPAN::Frontend->myprint("All modules are up to date for @args\n"); + } + } + if ($what eq "r") { + if ($version_zeroes) { + my $s_has = $version_zeroes > 1 ? "s have" : " has"; + $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }. + qq{a version number of 0\n}); + } + if ($version_undefs) { + my $s_has = $version_undefs > 1 ? "s have" : " has"; + $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }. + qq{parseable version number\n}); + } + } + @result; +} + +#-> sub CPAN::Shell::r ; +sub r { + shift->_u_r_common("r",@_); +} + +#-> sub CPAN::Shell::u ; +sub u { + shift->_u_r_common("u",@_); +} + +#-> sub CPAN::Shell::autobundle ; +sub autobundle { + my($self) = shift; + my(@bundle) = $self->_u_r_common("a",@_); + my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle"); + File::Path::mkpath($todir); + unless (-d $todir) { + $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n"); + return; + } + my($y,$m,$d) = (localtime)[5,4,3]; + $y+=1900; + $m++; + my($c) = 0; + my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c; + my($to) = MM->catfile($todir,"$me.pm"); + while (-f $to) { + $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c; + $to = MM->catfile($todir,"$me.pm"); + } + my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!"; + $fh->print( + "package Bundle::$me;\n\n", + "\$VERSION = '0.01';\n\n", + "1;\n\n", + "__END__\n\n", + "=head1 NAME\n\n", + "Bundle::$me - Snapshot of installation on ", + $Config::Config{'myhostname'}, + " on ", + scalar(localtime), + "\n\n=head1 SYNOPSIS\n\n", + "perl -MCPAN -e 'install Bundle::$me'\n\n", + "=head1 CONTENTS\n\n", + join("\n", @bundle), + "\n\n=head1 CONFIGURATION\n\n", + Config->myconfig, + "\n\n=head1 AUTHOR\n\n", + "This Bundle has been generated automatically ", + "by the autobundle routine in CPAN.pm.\n", + ); + $fh->close; + $CPAN::Frontend->myprint("\nWrote bundle file + $to\n\n"); +} + +#-> sub CPAN::Shell::expand ; +sub expand { + shift; + my($type,@args) = @_; + my($arg,@m); + for $arg (@args) { + my $regex; + if ($arg =~ m|^/(.*)/$|) { + $regex = $1; + } + my $class = "CPAN::$type"; + my $obj; + if (defined $regex) { + for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) { + push @m, $obj + if + $obj->id =~ /$regex/i + or + ( + ( + $] < 5.00303 ### provide sort of compatibility with 5.003 + || + $obj->can('name') + ) + && + $obj->name =~ /$regex/i + ); + } + } else { + my($xarg) = $arg; + if ( $type eq 'Bundle' ) { + $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/; + } + if ($CPAN::META->exists($class,$xarg)) { + $obj = $CPAN::META->instance($class,$xarg); + } elsif ($CPAN::META->exists($class,$arg)) { + $obj = $CPAN::META->instance($class,$arg); + } else { + next; + } + push @m, $obj; + } + } + return wantarray ? @m : $m[0]; +} + +#-> sub CPAN::Shell::format_result ; +sub format_result { + my($self) = shift; + my($type,@args) = @_; + @args = '/./' unless @args; + my(@result) = $self->expand($type,@args); + my $result = @result == 1 ? + $result[0]->as_string : + join "", map {$_->as_glimpse} @result; + $result ||= "No objects of type $type found for argument @args\n"; + $result; +} + +# The only reason for this method is currently to have a reliable +# debugging utility that reveals which output is going through which +# channel. No, I don't like the colors ;-) +sub print_ornamented { + my($self,$what,$ornament) = @_; + my $longest = 0; + my $ornamenting = 0; # turn the colors on + + if ($ornamenting) { + unless (defined &color) { + if ($CPAN::META->has_inst("Term::ANSIColor")) { + import Term::ANSIColor "color"; + } else { + *color = sub { return "" }; + } + } + for my $line (split /\n/, $what) { + $longest = length($line) if length($line) > $longest; + } + my $sprintf = "%-" . $longest . "s"; + while ($what){ + $what =~ s/(.*\n?)//m; + my $line = $1; + last unless $line; + my($nl) = chomp $line ? "\n" : ""; + # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n"; + print color($ornament), sprintf($sprintf,$line), color("reset"), $nl; + } + } else { + print $what; + } +} + +sub myprint { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold blue on_yellow'); +} + +sub myexit { + my($self,$what) = @_; + $self->myprint($what); + exit; +} + +sub mywarn { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_yellow'); +} + +sub myconfess { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_white'); + Carp::confess "died"; +} + +sub mydie { + my($self,$what) = @_; + $self->print_ornamented($what, 'bold red on_white'); + die "\n"; +} + +#-> sub CPAN::Shell::rematein ; +sub rematein { + shift; + my($meth,@some) = @_; + my $pragma = ""; + if ($meth eq 'force') { + $pragma = $meth; + $meth = shift @some; + } + CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG; + my($s,@s); + foreach $s (@some) { + my $obj; + if (ref $s) { + $obj = $s; + } elsif ($s =~ m|/|) { # looks like a file + $obj = $CPAN::META->instance('CPAN::Distribution',$s); + } elsif ($s =~ m|^Bundle::|) { + $obj = $CPAN::META->instance('CPAN::Bundle',$s); + } else { + $obj = $CPAN::META->instance('CPAN::Module',$s) + if $CPAN::META->exists('CPAN::Module',$s); + } + if (ref $obj) { + CPAN->debug( + qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}. + $obj->as_string. + qq{\]} + ) if $CPAN::DEBUG; + $obj->$pragma() + if + $pragma + && + ($] < 5.00303 || $obj->can($pragma)); ### compatibility with 5.003 + $obj->$meth(); + } elsif ($CPAN::META->exists('CPAN::Author',$s)) { + $obj = $CPAN::META->instance('CPAN::Author',$s); + $CPAN::Frontend->myprint( + join "", + "Don't be silly, you can't $meth ", + $obj->fullname, + " ;-)\n" + ); + } else { + $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is. +Try the command + + i /$s/ + +to find objects with similar identifiers. +}); + } + } +} + +#-> sub CPAN::Shell::force ; +sub force { shift->rematein('force',@_); } +#-> sub CPAN::Shell::get ; +sub get { shift->rematein('get',@_); } +#-> sub CPAN::Shell::readme ; +sub readme { shift->rematein('readme',@_); } +#-> sub CPAN::Shell::make ; +sub make { shift->rematein('make',@_); } +#-> sub CPAN::Shell::test ; +sub test { shift->rematein('test',@_); } +#-> sub CPAN::Shell::install ; +sub install { shift->rematein('install',@_); } +#-> sub CPAN::Shell::clean ; +sub clean { shift->rematein('clean',@_); } +#-> sub CPAN::Shell::look ; +sub look { shift->rematein('look',@_); } + +package CPAN::FTP; + +#-> sub CPAN::FTP::ftp_get ; +sub ftp_get { + my($class,$host,$dir,$file,$target) = @_; + $class->debug( + qq[Going to fetch file [$file] from dir [$dir] + on host [$host] as local [$target]\n] + ) if $CPAN::DEBUG; + my $ftp = Net::FTP->new($host); + return 0 unless defined $ftp; + $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG; + $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]); + unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){ + warn "Couldn't login on $host"; + return; + } + unless ( $ftp->cwd($dir) ){ + warn "Couldn't cwd $dir"; + return; + } + $ftp->binary; + $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG; + unless ( $ftp->get($file,$target) ){ + warn "Couldn't fetch $file from $host\n"; + return; + } + $ftp->quit; # it's ok if this fails + return 1; +} + +sub is_reachable { + my($self,$url) = @_; + return 1; # we can't simply roll our own, firewalls may break ping + return 0 unless $url; + return 1 if substr($url,0,4) eq "file"; + return 1 unless $url =~ m|://([^/]+)|; + my $host = $1; + require Net::Ping; + return 1 unless $Net::Ping::VERSION >= 2; + my $p; + eval {$p = Net::Ping->new("icmp");}; + eval {$p = Net::Ping->new("tcp");} if $@; + $CPAN::Frontend->mydie($@) if $@; + return $p->ping($host, 3); +} + +#-> sub CPAN::FTP::localize ; +# sorry for the ugly code here, I'll clean it up as soon as Net::FTP +# is in the core +sub localize { + my($self,$file,$aslocal,$force) = @_; + $force ||= 0; + Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])" + unless defined $aslocal; + $self->debug("file[$file] aslocal[$aslocal] force[$force]") + if $CPAN::DEBUG; + + return $aslocal if -f $aslocal && -r _ && !($force & 1); + my($restore) = 0; + if (-f $aslocal){ + rename $aslocal, "$aslocal.bak"; + $restore++; + } + + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }. + qq{directory "$aslocal_dir". + I\'ll continue, but if you encounter problems, they may be due + to insufficient permissions.\n}) unless -w $aslocal_dir; + + # Inheritance is not easier to manage than a few if/else branches + if ($CPAN::META->has_inst('LWP')) { + require LWP::UserAgent; + unless ($Ua) { + $Ua = LWP::UserAgent->new; + my($var); + $Ua->proxy('ftp', $var) + if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'}; + $Ua->proxy('http', $var) + if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; + $Ua->no_proxy($var) + if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'}; + } + } + + # Try the list of urls for each single object. We keep a record + # where we did get a file from + my(@reordered,$last); +#line 1621 + $last = $#{$CPAN::Config->{urllist}}; + if ($force & 2) { # local cpans probably out of date, don't reorder + @reordered = (0..$last); + } else { + @reordered = + sort { + (substr($CPAN::Config->{urllist}[$b],0,4) eq "file") + <=> + (substr($CPAN::Config->{urllist}[$a],0,4) eq "file") + or + defined($Thesite) + and + ($b == $Thesite) + <=> + ($a == $Thesite) + } 0..$last; + +# ((grep { substr($CPAN::Config->{urllist}[$_],0,4) +# eq "file" } 0..$last), +# (grep { substr($CPAN::Config->{urllist}[$_],0,4) +# ne "file" } 0..$last)); + } + my($level,@levels); + if ($Themethod) { + @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/); + } else { + @levels = qw/easy hard hardest/; + } + for $level (@levels) { + my $method = "host$level"; + my @host_seq = $level eq "easy" ? + @reordered : 0..$last; # reordered has CDROM up front + my $ret = $self->$method(\@host_seq,$file,$aslocal); + if ($ret) { + $Themethod = $level; + $self->debug("level[$level]") if $CPAN::DEBUG; + return $ret; + } + } + my(@mess); + push @mess, + qq{Please check, if the URLs I found in your configuration file \(}. + join(", ", @{$CPAN::Config->{urllist}}). + qq{\) are valid. The urllist can be edited.}, + qq{E.g. with ``o conf urllist push ftp://myurl/''}; + $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n"); + sleep 2; + $CPAN::Frontend->myprint("Cannot fetch $file\n\n"); + if ($restore) { + rename "$aslocal.bak", $aslocal; + $CPAN::Frontend->myprint("Trying to get away with old file:\n" . + $self->ls($aslocal)); + return $aslocal; + } + return; +} + +sub hosteasy { + my($self,$host_seq,$file,$aslocal) = @_; + my($i); + HOSTEASY: for $i (@$host_seq) { + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n"); + sleep 2; + next; + } + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + $self->debug("localizing perlish[$url]") if $CPAN::DEBUG; + if ($url =~ /^file:/) { + my $l; + if ($CPAN::META->has_inst('LWP')) { + require URI::URL; + my $u = URI::URL->new($url); + $l = $u->path; + } else { # works only on Unix, is poorly constructed, but + # hopefully better than nothing. + # RFC 1738 says fileurl BNF is + # fileurl = "file://" [ host | "localhost" ] "/" fpath + # Thanks to "Mark D. Baushke" <mdb@cisco.com> for + # the code + ($l = $url) =~ s,^file://[^/]+,,; # discard the host part + $l =~ s/^file://; # assume they meant file://localhost + } + if ( -f $l && -r _) { + $Thesite = $i; + return $l; + } + # Maybe mirror has compressed it? + if (-f "$l.gz") { + $self->debug("found compressed $l.gz") if $CPAN::DEBUG; + system("$CPAN::Config->{gzip} -dc $l.gz > $aslocal"); + if ( -f $aslocal) { + $Thesite = $i; + return $aslocal; + } + } + } + if ($CPAN::META->has_inst('LWP')) { + $CPAN::Frontend->myprint("Fetching with LWP: + $url +"); + my $res = $Ua->mirror($url, $aslocal); + if ($res->is_success) { + $Thesite = $i; + return $aslocal; + } elsif ($url !~ /\.gz$/) { + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint("Fetching with LWP: + $gzurl +"); + $res = $Ua->mirror($gzurl, "$aslocal.gz"); + if ($res->is_success && + system("$CPAN::Config->{gzip} -d $aslocal.gz")==0) { + $Thesite = $i; + return $aslocal; + } else { + next HOSTEASY ; + } + } else { + next HOSTEASY ; + } + } + if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + # that's the nice and easy way thanks to Graham + my($host,$dir,$getfile) = ($1,$2,$3); + if ($CPAN::META->has_inst('Net::FTP')) { + $dir =~ s|/+|/|g; + $CPAN::Frontend->myprint("Fetching with Net::FTP: + $aslocal +"); + $self->debug("getfile[$getfile]dir[$dir]host[$host]" . + "aslocal[$aslocal]") if $CPAN::DEBUG; + if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) { + $Thesite = $i; + return $aslocal; + } + if ($aslocal !~ /\.gz$/) { + my $gz = "$aslocal.gz"; + $CPAN::Frontend->myprint("Fetching with Net::FTP + $gz +"); + if (CPAN::FTP->ftp_get($host, + $dir, + "$getfile.gz", + $gz) && + system("$CPAN::Config->{gzip} -d $gz")==0 ){ + $Thesite = $i; + return $aslocal; + } + } + next HOSTEASY; + } + } + } +} + +sub hosthard { + my($self,$host_seq,$file,$aslocal) = @_; + + # Came back if Net::FTP couldn't establish connection (or + # failed otherwise) Maybe they are behind a firewall, but they + # gave us a socksified (or other) ftp program... + + my($i); + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + HOSTHARD: for $i (@$host_seq) { + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; + } + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + my($host,$dir,$getfile); + if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + ($host,$dir,$getfile) = ($1,$2,$3); + } else { + next HOSTHARD; # who said, we could ftp anything except ftp? + } + $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG; + my($f,$funkyftp); + for $f ('lynx','ncftp') { + next unless exists $CPAN::Config->{$f}; + $funkyftp = $CPAN::Config->{$f}; + next unless defined $funkyftp; + next if $funkyftp =~ /^\s*$/; + my($want_compressed); + my $aslocal_uncompressed; + ($aslocal_uncompressed = $aslocal) =~ s/\.gz//; + my($source_switch) = ""; + $source_switch = "-source" if $funkyftp =~ /\blynx$/; + $source_switch = "-c" if $funkyftp =~ /\bncftp$/; + $CPAN::Frontend->myprint( + qq{ +Trying with "$funkyftp $source_switch" to get + $url +}); + my($system) = "$funkyftp $source_switch '$url' > ". + "$aslocal_uncompressed"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + -s $aslocal_uncompressed # lynx returns 0 on my + # system even if it fails + ) { + if ($aslocal_uncompressed ne $aslocal) { + # test gzip integrity + $system = + "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed"; + if (system($system) == 0) { + rename $aslocal_uncompressed, $aslocal; + } else { + $system = + "$CPAN::Config->{'gzip'} $aslocal_uncompressed"; + system($system); + } + $Thesite = $i; + return $aslocal; + } + } elsif ($url !~ /\.gz$/) { + my $gz = "$aslocal.gz"; + my $gzurl = "$url.gz"; + $CPAN::Frontend->myprint( + qq{ +Trying with "$funkyftp $source_switch" to get + $url.gz +}); + my($system) = "$funkyftp $source_switch '$url.gz' > ". + "$aslocal_uncompressed.gz"; + $self->debug("system[$system]") if $CPAN::DEBUG; + my($wstatus); + if (($wstatus = system($system)) == 0 + && + -s "$aslocal_uncompressed.gz" + ) { + # test gzip integrity + $system = + "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed.gz"; + $CPAN::Frontend->mywarn("system[$system]"); + if (system($system) == 0) { + $system = "$CPAN::Config->{'gzip'} -dc ". + "$aslocal_uncompressed.gz > $aslocal"; + $CPAN::Frontend->mywarn("system[$system]"); + system($system); + } else { + rename $aslocal_uncompressed, $aslocal; + } +#line 1739 + $Thesite = $i; + return $aslocal; + } + } else { + my $estatus = $wstatus >> 8; + my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : ""; + $CPAN::Frontend->myprint(qq{ +System call "$system" +returned status $estatus (wstat $wstatus)$size +}); + } + } + } +} + +sub hosthardest { + my($self,$host_seq,$file,$aslocal) = @_; + + my($i); + my($aslocal_dir) = File::Basename::dirname($aslocal); + File::Path::mkpath($aslocal_dir); + HOSTHARDEST: for $i (@$host_seq) { + unless (length $CPAN::Config->{'ftp'}) { + $CPAN::Frontend->myprint("No external ftp command available\n\n"); + last HOSTHARDEST; + } + my $url = $CPAN::Config->{urllist}[$i]; + unless ($self->is_reachable($url)) { + $CPAN::Frontend->myprint("Skipping $url (not reachable)\n"); + next; + } + $url .= "/" unless substr($url,-1) eq "/"; + $url .= $file; + $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG; + unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { + next; + } + my($host,$dir,$getfile) = ($1,$2,$3); + my($netrcfile,$fh); + my $timestamp = 0; + my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime, + $ctime,$blksize,$blocks) = stat($aslocal); + $timestamp = $mtime ||= 0; + my($netrc) = CPAN::FTP::netrc->new; + my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : ""; + my $targetfile = File::Basename::basename($aslocal); + my(@dialog); + push( + @dialog, + "lcd $aslocal_dir", + "cd /", + map("cd $_", split "/", $dir), # RFC 1738 + "bin", + "get $getfile $targetfile", + "quit" + ); + if (! $netrc->netrc) { + CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG; + } elsif ($netrc->hasdefault || $netrc->contains($host)) { + CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]", + $netrc->hasdefault, + $netrc->contains($host))) if $CPAN::DEBUG; + if ($netrc->protected) { + $CPAN::Frontend->myprint(qq{ + Trying with external ftp to get + $url + As this requires some features that are not thoroughly tested, we\'re + not sure, that we get it right.... + +} + ); + $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host", + @dialog); + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $mtime ||= 0; + if ($mtime > $timestamp) { + $CPAN::Frontend->myprint("GOT $aslocal\n"); + $Thesite = $i; + return $aslocal; + } else { + $CPAN::Frontend->myprint("Hmm... Still failed!\n"); + } + } else { + $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }. + qq{correctly protected.\n}); + } + } else { + $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host + nor does it have a default entry\n"); + } + + # OK, they don't have a valid ~/.netrc. Use 'ftp -n' + # then and login manually to host, using e-mail as + # password. + $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n}); + unshift( + @dialog, + "open $host", + "user anonymous $Config::Config{'cf_email'}" + ); + $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog); + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal); + $mtime ||= 0; + if ($mtime > $timestamp) { + $CPAN::Frontend->myprint("GOT $aslocal\n"); + $Thesite = $i; + return $aslocal; + } else { + $CPAN::Frontend->myprint("Bad luck... Still failed!\n"); + } + $CPAN::Frontend->myprint("Can't access URL $url.\n\n"); + sleep 2; + } +} + +sub talk_ftp { + my($self,$command,@dialog) = @_; + my $fh = FileHandle->new; + $fh->open("|$command") or die "Couldn't open ftp: $!"; + foreach (@dialog) { $fh->print("$_\n") } + $fh->close; # Wait for process to complete + my $wstatus = $?; + my $estatus = $wstatus >> 8; + $CPAN::Frontend->myprint(qq{ +Subprocess "|$command" + returned status $estatus (wstat $wstatus) +}) if $wstatus; + +} + +# find2perl needs modularization, too, all the following is stolen +# from there +sub ls { + my($self,$name) = @_; + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm, + $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name); + + my($perms,%user,%group); + my $pname = $name; + + if ($blocks) { + $blocks = int(($blocks + 1) / 2); + } + else { + $blocks = int(($sizemm + 1023) / 1024); + } + + if (-f _) { $perms = '-'; } + elsif (-d _) { $perms = 'd'; } + elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; } + elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; } + elsif (-p _) { $perms = 'p'; } + elsif (-S _) { $perms = 's'; } + else { $perms = 'l'; $pname .= ' -> ' . readlink($_); } + + my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx'); + my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); + my $tmpmode = $mode; + my $tmp = $rwx[$tmpmode & 7]; + $tmpmode >>= 3; + $tmp = $rwx[$tmpmode & 7] . $tmp; + $tmpmode >>= 3; + $tmp = $rwx[$tmpmode & 7] . $tmp; + substr($tmp,2,1) =~ tr/-x/Ss/ if -u _; + substr($tmp,5,1) =~ tr/-x/Ss/ if -g _; + substr($tmp,8,1) =~ tr/-x/Tt/ if -k _; + $perms .= $tmp; + + my $user = $user{$uid} || $uid; # too lazy to implement lookup + my $group = $group{$gid} || $gid; + + my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime); + my($timeyear); + my($moname) = $moname[$mon]; + if (-M _ > 365.25 / 2) { + $timeyear = $year + 1900; + } + else { + $timeyear = sprintf("%02d:%02d", $hour, $min); + } + + sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n", + $ino, + $blocks, + $perms, + $nlink, + $user, + $group, + $sizemm, + $moname, + $mday, + $timeyear, + $pname; +} + +package CPAN::FTP::netrc; + +sub new { + my($class) = @_; + my $file = MM->catfile($ENV{HOME},".netrc"); + + my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat($file); + $mode ||= 0; + my $protected = 0; + + my($fh,@machines,$hasdefault); + $hasdefault = 0; + $fh = FileHandle->new or die "Could not create a filehandle"; + + if($fh->open($file)){ + $protected = ($mode & 077) == 0; + local($/) = ""; + NETRC: while (<$fh>) { + my(@tokens) = split " ", $_; + TOKEN: while (@tokens) { + my($t) = shift @tokens; + if ($t eq "default"){ + $hasdefault++; + last NETRC; + } + last TOKEN if $t eq "macdef"; + if ($t eq "machine") { + push @machines, shift @tokens; + } + } + } + } else { + $file = $hasdefault = $protected = ""; + } + + bless { + 'mach' => [@machines], + 'netrc' => $file, + 'hasdefault' => $hasdefault, + 'protected' => $protected, + }, $class; +} + +sub hasdefault { shift->{'hasdefault'} } +sub netrc { shift->{'netrc'} } +sub protected { shift->{'protected'} } +sub contains { + my($self,$mach) = @_; + for ( @{$self->{'mach'}} ) { + return 1 if $_ eq $mach; + } + return 0; +} + +package CPAN::Complete; + +#-> sub CPAN::Complete::cpl ; +sub cpl { + my($word,$line,$pos) = @_; + $word ||= ""; + $line ||= ""; + $pos ||= 0; + CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + $line =~ s/^\s*//; + if ($line =~ s/^(force\s*)//) { + $pos -= length($1); + } + my @return; + if ($pos == 0) { + @return = grep( + /^$word/, + sort qw( + ! a b d h i m o q r u autobundle clean + make test install force reload look + ) + ); + } elsif ( $line !~ /^[\!abdhimorutl]/ ) { + @return = (); + } elsif ($line =~ /^a\s/) { + @return = cplx('CPAN::Author',$word); + } elsif ($line =~ /^b\s/) { + @return = cplx('CPAN::Bundle',$word); + } elsif ($line =~ /^d\s/) { + @return = cplx('CPAN::Distribution',$word); + } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) { + @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word)); + } elsif ($line =~ /^i\s/) { + @return = cpl_any($word); + } elsif ($line =~ /^reload\s/) { + @return = cpl_reload($word,$line,$pos); + } elsif ($line =~ /^o\s/) { + @return = cpl_option($word,$line,$pos); + } else { + @return = (); + } + return @return; +} + +#-> sub CPAN::Complete::cplx ; +sub cplx { + my($class, $word) = @_; + grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class); +} + +#-> sub CPAN::Complete::cpl_any ; +sub cpl_any { + my($word) = shift; + return ( + cplx('CPAN::Author',$word), + cplx('CPAN::Bundle',$word), + cplx('CPAN::Distribution',$word), + cplx('CPAN::Module',$word), + ); +} + +#-> sub CPAN::Complete::cpl_reload ; +sub cpl_reload { + my($word,$line,$pos) = @_; + $word ||= ""; + my(@words) = split " ", $line; + CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + my(@ok) = qw(cpan index); + return @ok if @words == 1; + return grep /^\Q$word\E/, @ok if @words == 2 && $word; +} + +#-> sub CPAN::Complete::cpl_option ; +sub cpl_option { + my($word,$line,$pos) = @_; + $word ||= ""; + my(@words) = split " ", $line; + CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; + my(@ok) = qw(conf debug); + return @ok if @words == 1; + return grep /^\Q$word\E/, @ok if @words == 2 && length($word); + if (0) { + } elsif ($words[1] eq 'index') { + return (); + } elsif ($words[1] eq 'conf') { + return CPAN::Config::cpl(@_); + } elsif ($words[1] eq 'debug') { + return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all'; + } +} + +package CPAN::Index; + +#-> sub CPAN::Index::force_reload ; +sub force_reload { + my($class) = @_; + $CPAN::Index::last_time = 0; + $class->reload(1); +} + +#-> sub CPAN::Index::reload ; +sub reload { + my($cl,$force) = @_; + my $time = time; + + # XXX check if a newer one is available. (We currently read it + # from time to time) + for ($CPAN::Config->{index_expire}) { + $_ = 0.001 unless $_ > 0.001; + } + return if $last_time + $CPAN::Config->{index_expire}*86400 > $time + and ! $force; + my($debug,$t2); + $last_time = $time; + + my $needshort = $^O eq "dos"; + + $cl->rd_authindex($cl->reload_x( + "authors/01mailrc.txt.gz", + $needshort ? "01mailrc.gz" : "", + $force)); + $t2 = time; + $debug = "timing reading 01[".($t2 - $time)."]"; + $time = $t2; + return if $CPAN::Signal; # this is sometimes lengthy + $cl->rd_modpacks($cl->reload_x( + "modules/02packages.details.txt.gz", + $needshort ? "02packag.gz" : "", + $force)); + $t2 = time; + $debug .= "02[".($t2 - $time)."]"; + $time = $t2; + return if $CPAN::Signal; # this is sometimes lengthy + $cl->rd_modlist($cl->reload_x( + "modules/03modlist.data.gz", + $needshort ? "03mlist.gz" : "", + $force)); + $t2 = time; + $debug .= "03[".($t2 - $time)."]"; + $time = $t2; + CPAN->debug($debug) if $CPAN::DEBUG; +} + +#-> sub CPAN::Index::reload_x ; +sub reload_x { + my($cl,$wanted,$localname,$force) = @_; + $force |= 2; # means we're dealing with an index here + CPAN::Config->load; # we should guarantee loading wherever we rely + # on Config XXX + $localname ||= $wanted; + my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'}, + $localname); + if ( + -f $abs_wanted && + -M $abs_wanted < $CPAN::Config->{'index_expire'} && + !($force & 1) + ) { + my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s"; + $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }. + qq{day$s. I\'ll use that.}); + return $abs_wanted; + } else { + $force |= 1; # means we're quite serious about it. + } + return CPAN::FTP->localize($wanted,$abs_wanted,$force); +} + +#-> sub CPAN::Index::rd_authindex ; +sub rd_authindex { + my($cl,$index_target) = @_; + return unless defined $index_target; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; + $CPAN::Frontend->myprint("Going to read $index_target\n"); + my $fh = FileHandle->new("$pipe|"); + while (<$fh>) { + chomp; + my($userid,$fullname,$email) = + /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/; + next unless $userid && $fullname && $email; + + # instantiate an author object + my $userobj = $CPAN::META->instance('CPAN::Author',$userid); + $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); + return if $CPAN::Signal; + } + $fh->close; + $? and Carp::croak "FAILED $pipe: exit status [$?]"; +} + +#-> sub CPAN::Index::rd_modpacks ; +sub rd_modpacks { + my($cl,$index_target) = @_; + return unless defined $index_target; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; + $CPAN::Frontend->myprint("Going to read $index_target\n"); + my $fh = FileHandle->new("$pipe|"); + while (<$fh>) { + last if /^\s*$/; + } + while (<$fh>) { + chomp; + my($mod,$version,$dist) = split; +### $version =~ s/^\+//; + + # if it as a bundle, instatiate a bundle object + my($bundle,$id,$userid); + + if ($mod eq 'CPAN') { + local($^W)= 0; + if ($version > $CPAN::VERSION){ + $CPAN::Frontend->myprint(qq{ + There\'s a new CPAN.pm version (v$version) available! + You might want to try + install CPAN + reload cpan + without quitting the current session. It should be a seamless upgrade + while we are running... +}); + sleep 2; + $CPAN::Frontend->myprint(qq{\n}); + } + last if $CPAN::Signal; + } elsif ($mod =~ /^Bundle::(.*)/) { + $bundle = $1; + } + + if ($bundle){ + $id = $CPAN::META->instance('CPAN::Bundle',$mod); + # Let's make it a module too, because bundles have so much + # in common with modules + $CPAN::META->instance('CPAN::Module',$mod); + +# This "next" makes us faster but if the job is running long, we ignore +# rereads which is bad. So we have to be a bit slower again. +# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) { +# next; + + } + else { + # instantiate a module object + $id = $CPAN::META->instance('CPAN::Module',$mod); + } + + if ($id->cpan_file ne $dist){ + # determine the author + ($userid) = $dist =~ /([^\/]+)/; + $id->set( + 'CPAN_USERID' => $userid, + 'CPAN_VERSION' => $version, + 'CPAN_FILE' => $dist + ); + } + + # instantiate a distribution object + unless ($CPAN::META->exists('CPAN::Distribution',$dist)) { + $CPAN::META->instance( + 'CPAN::Distribution' => $dist + )->set( + 'CPAN_USERID' => $userid + ); + } + + return if $CPAN::Signal; + } + $fh->close; + $? and Carp::croak "FAILED $pipe: exit status [$?]"; +} + +#-> sub CPAN::Index::rd_modlist ; +sub rd_modlist { + my($cl,$index_target) = @_; + return unless defined $index_target; + my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target"; + $CPAN::Frontend->myprint("Going to read $index_target\n"); + my $fh = FileHandle->new("$pipe|"); + my $eval; + while (<$fh>) { + if (/^Date:\s+(.*)/){ + return if $date_of_03 eq $1; + ($date_of_03) = $1; + } + last if /^\s*$/; + } + local($/) = undef; + $eval = <$fh>; + $fh->close; + $eval .= q{CPAN::Modulelist->data;}; + local($^W) = 0; + my($comp) = Safe->new("CPAN::Safe1"); + my $ret = $comp->reval($eval); + Carp::confess($@) if $@; + return if $CPAN::Signal; + for (keys %$ret) { + my $obj = $CPAN::META->instance(CPAN::Module,$_); + $obj->set(%{$ret->{$_}}); + return if $CPAN::Signal; + } +} + +package CPAN::InfoObj; + +#-> sub CPAN::InfoObj::new ; +sub new { my $this = bless {}, shift; %$this = @_; $this } + +#-> sub CPAN::InfoObj::set ; +sub set { + my($self,%att) = @_; + my(%oldatt) = %$self; + %$self = (%oldatt, %att); +} + +#-> sub CPAN::InfoObj::id ; +sub id { shift->{'ID'} } + +#-> sub CPAN::InfoObj::as_glimpse ; +sub as_glimpse { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %s\n", $class, $self->{ID}; + join "", @m; +} + +#-> sub CPAN::InfoObj::as_string ; +sub as_string { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, $class, " id = $self->{ID}\n"; + for (sort keys %$self) { + next if $_ eq 'ID'; + my $extra = ""; + $_ eq "CPAN_USERID" and $extra = " (".$self->author.")"; + if (ref($self->{$_}) eq "ARRAY") { # Should we setup a language interface? XXX + push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra; + } else { + push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra; + } + } + join "", @m, "\n"; +} + +#-> sub CPAN::InfoObj::author ; +sub author { + my($self) = @_; + $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname; +} + +package CPAN::Author; + +#-> sub CPAN::Author::as_glimpse ; +sub as_glimpse { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; + join "", @m; +} + +# Dead code, I would have liked to have,,, but it was never reached,,, +#sub make { +# my($self) = @_; +# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n"; +#} + +#-> sub CPAN::Author::fullname ; +sub fullname { shift->{'FULLNAME'} } +*name = \&fullname; +#-> sub CPAN::Author::email ; +sub email { shift->{'EMAIL'} } + +package CPAN::Distribution; + +#-> sub CPAN::Distribution::called_for ; +sub called_for { + my($self,$id) = @_; + $self->{'CALLED_FOR'} = $id if defined $id; + return $self->{'CALLED_FOR'}; +} + +#-> sub CPAN::Distribution::get ; +sub get { + my($self) = @_; + EXCUSE: { + my @e; + exists $self->{'build_dir'} and push @e, + "Unwrapped into directory $self->{'build_dir'}"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + my($local_file); + my($local_wanted) = + MM->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split("/",$self->{ID}) + ); + + $self->debug("Doing localize") if $CPAN::DEBUG; + $local_file = + CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted) + or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); + $self->{localfile} = $local_file; + my $builddir = $CPAN::META->{cachemgr}->dir; + $self->debug("doing chdir $builddir") if $CPAN::DEBUG; + chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); + my $packagedir; + + $self->debug("local_file[$local_file]") if $CPAN::DEBUG; + if ($CPAN::META->has_inst('MD5')) { + $self->debug("MD5 is installed, verifying"); + $self->verifyMD5; + } else { + $self->debug("MD5 is NOT installed"); + } + $self->debug("Removing tmp") if $CPAN::DEBUG; + File::Path::rmtree("tmp"); + mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!"; + chdir "tmp"; + $self->debug("Changed directory to tmp") if $CPAN::DEBUG; + if (! $local_file) { + Carp::croak "bad download, can't do anything :-(\n"; + } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){ + $self->untar_me($local_file); + } elsif ( $local_file =~ /\.zip$/i ) { + $self->unzip_me($local_file); + } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) { + $self->pm2dir_me($local_file); + } else { + $self->{archived} = "NO"; + } + chdir ".."; + if ($self->{archived} ne 'NO') { + chdir "tmp"; + # Let's check if the package has its own directory. + my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!"); + my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC?? + $dh->close; + my ($distdir,$packagedir); + if (@readdir == 1 && -d $readdir[0]) { + $distdir = $readdir[0]; + $packagedir = MM->catdir($builddir,$distdir); + -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n"); + File::Path::rmtree($packagedir); + rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!"); + } else { + my $pragmatic_dir = $self->{'CPAN_USERID'} . '000'; + $pragmatic_dir =~ s/\W_//g; + $pragmatic_dir++ while -d "../$pragmatic_dir"; + $packagedir = MM->catdir($builddir,$pragmatic_dir); + File::Path::mkpath($packagedir); + my($f); + for $f (@readdir) { # is already without "." and ".." + my $to = MM->catdir($packagedir,$f); + rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!"); + } + } + $self->{'build_dir'} = $packagedir; + chdir ".."; + + $self->debug("Changed directory to .. (self is $self [".$self->as_string."])") + if $CPAN::DEBUG; + File::Path::rmtree("tmp"); + if ($CPAN::Config->{keep_source_where} =~ /^no/i ){ + $CPAN::Frontend->myprint("Going to unlink $local_file\n"); + unlink $local_file or Carp::carp "Couldn't unlink $local_file"; + } + my($makefilepl) = MM->catfile($packagedir,"Makefile.PL"); + unless (-f $makefilepl) { + my($configure) = MM->catfile($packagedir,"Configure"); + if (-f $configure) { + # do we have anything to do? + $self->{'configure'} = $configure; + } else { + my $fh = FileHandle->new(">$makefilepl") + or Carp::croak("Could not open >$makefilepl"); + my $cf = $self->called_for || "unknown"; + $fh->print( +qq{# This Makefile.PL has been autogenerated by the module CPAN.pm +# because there was no Makefile.PL supplied. +# Autogenerated on: }.scalar localtime().qq{ + + use ExtUtils::MakeMaker; + WriteMakefile(NAME => q[$cf]); + +}); + $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.\n}. + qq{ Writing one on our own (calling it $cf)\n}); + } + } + } + return $self; +} + +sub untar_me { + my($self,$local_file) = @_; + $self->{archived} = "tar"; + my $system = "$CPAN::Config->{gzip} --decompress --stdout " . + "$local_file | $CPAN::Config->{tar} xvf -"; + if (system($system)== 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub unzip_me { + my($self,$local_file) = @_; + $self->{archived} = "zip"; + my $system = "$CPAN::Config->{unzip} $local_file"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +sub pm2dir_me { + my($self,$local_file) = @_; + $self->{archived} = "pm"; + my $to = File::Basename::basename($local_file); + $to =~ s/\.(gz|Z)$//; + my $system = "$CPAN::Config->{gzip} --decompress --stdout ". + "$local_file > $to"; + if (system($system) == 0) { + $self->{unwrapped} = "YES"; + } else { + $self->{unwrapped} = "NO"; + } +} + +#-> sub CPAN::Distribution::new ; +sub new { + my($class,%att) = @_; + + $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); + + my $this = { %att }; + return bless $this, $class; +} + +#-> sub CPAN::Distribution::look ; +sub look { + my($self) = @_; + if ( $CPAN::Config->{'shell'} ) { + $CPAN::Frontend->myprint(qq{ +Trying to open a subshell in the build directory... +}); + } else { + $CPAN::Frontend->myprint(qq{ +Your configuration does not define a value for subshells. +Please define it with "o conf shell <your shell>" +}); + return; + } + my $dist = $self->id; + my $dir = $self->dir or $self->get; + $dir = $self->dir; + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $pwd = CPAN->$getcwd(); + chdir($dir); + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + system($CPAN::Config->{'shell'}) == 0 + or $CPAN::Frontend->mydie("Subprocess shell error"); + chdir($pwd); +} + +#-> sub CPAN::Distribution::readme ; +sub readme { + my($self) = @_; + my($dist) = $self->id; + my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/; + $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; + my($local_file); + my($local_wanted) = + MM->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split("/","$sans.readme"), + ); + $self->debug("Doing localize") if $CPAN::DEBUG; + $local_file = CPAN::FTP->localize("authors/id/$sans.readme", + $local_wanted) + or $CPAN::Frontend->mydie(qq{No $sans.readme found});; + my $fh_pager = FileHandle->new; + local($SIG{PIPE}) = "IGNORE"; + $fh_pager->open("|$CPAN::Config->{'pager'}") + or die "Could not open pager $CPAN::Config->{'pager'}: $!"; + my $fh_readme = FileHandle->new; + $fh_readme->open($local_file) + or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); + $CPAN::Frontend->myprint(qq{ +Displaying file + $local_file +with pager "$CPAN::Config->{'pager'}" +}); + sleep 2; + $fh_pager->print(<$fh_readme>); +} + +#-> sub CPAN::Distribution::verifyMD5 ; +sub verifyMD5 { + my($self) = @_; + EXCUSE: { + my @e; + $self->{MD5_STATUS} ||= ""; + $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + my($lc_want,$lc_file,@local,$basename); + @local = split("/",$self->{ID}); + pop @local; + push @local, "CHECKSUMS"; + $lc_want = + MM->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @local); + local($") = "/"; + if ( + -s $lc_want + && + $self->MD5_check_file($lc_want) + ) { + return $self->{MD5_STATUS} = "OK"; + } + $lc_file = CPAN::FTP->localize("authors/id/@local", + $lc_want,1); + unless ($lc_file) { + $local[-1] .= ".gz"; + $lc_file = CPAN::FTP->localize("authors/id/@local", + "$lc_want.gz",1); + if ($lc_file) { + my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file); + system(@system) == 0 or die "Could not uncompress $lc_file"; + $lc_file =~ s/\.gz$//; + } else { + return; + } + } + $self->MD5_check_file($lc_file); +} + +#-> sub CPAN::Distribution::MD5_check_file ; +sub MD5_check_file { + my($self,$chk_file) = @_; + my($cksum,$file,$basename); + $file = $self->{localfile}; + $basename = File::Basename::basename($file); + my $fh = FileHandle->new; + if (open $fh, $chk_file){ + local($/); + my $eval = <$fh>; + close $fh; + my($comp) = Safe->new(); + $cksum = $comp->reval($eval); + if ($@) { + rename $chk_file, "$chk_file.bad"; + Carp::confess($@) if $@; + } + } else { + Carp::carp "Could not open $chk_file for reading"; + } + if ($cksum->{$basename}->{md5}) { + $self->debug("Found checksum for $basename:" . + "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG; + my $pipe = "$CPAN::Config->{gzip} --decompress ". + "--stdout $file|"; + if ( + open($fh, $file) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{md5}) + or + open($fh, $pipe) && + binmode $fh && + $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'}) + ){ + $CPAN::Frontend->myprint("Checksum for $file ok\n"); + return $self->{MD5_STATUS} = "OK"; + } else { + $CPAN::Frontend->myprint(qq{Checksum mismatch for }. + qq{distribution file. }. + qq{Please investigate.\n\n}. + $self->as_string, + $CPAN::META->instance( + 'CPAN::Author', + $self->{CPAN_USERID} + )->as_string); + my $wrap = qq{I\'d recommend removing $file. It seems to +be a bogus file. Maybe you have configured your \`urllist\' with a +bad URL. Please check this array with \`o conf urllist\', and +retry.}; + $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap)); + $CPAN::Frontend->myprint("\n\n"); + sleep 3; + return; + } + close $fh if fileno($fh); + } else { + $self->{MD5_STATUS} ||= ""; + if ($self->{MD5_STATUS} eq "NIL") { + $CPAN::Frontend->myprint(qq{ +No md5 checksum for $basename in local $chk_file. +Removing $chk_file +}); + unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!"); + sleep 1; + } + $self->{MD5_STATUS} = "NIL"; + return; + } +} + +#-> sub CPAN::Distribution::eq_MD5 ; +sub eq_MD5 { + my($self,$fh,$expectMD5) = @_; + my $md5 = MD5->new; + $md5->addfile($fh); + my $hexdigest = $md5->hexdigest; + $hexdigest eq $expectMD5; +} + +#-> sub CPAN::Distribution::force ; +sub force { + my($self) = @_; + $self->{'force_update'}++; + delete $self->{'MD5_STATUS'}; + delete $self->{'archived'}; + delete $self->{'build_dir'}; + delete $self->{'localfile'}; + delete $self->{'make'}; + delete $self->{'install'}; + delete $self->{'unwrapped'}; + delete $self->{'writemakefile'}; +} + +#-> sub CPAN::Distribution::perl ; +sub perl { + my($self) = @_; + my($perl) = MM->file_name_is_absolute($^X) ? $^X : ""; + my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $pwd = CPAN->$getcwd(); + my $candidate = MM->catfile($pwd,$^X); + $perl ||= $candidate if MM->maybe_command($candidate); + unless ($perl) { + my ($component,$perl_name); + DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { + PATH_COMPONENT: foreach $component (MM->path(), + $Config::Config{'binexp'}) { + next unless defined($component) && $component; + my($abs) = MM->catfile($component,$perl_name); + if (MM->maybe_command($abs)) { + $perl = $abs; + last DIST_PERLNAME; + } + } + } + } + $perl; +} + +#-> sub CPAN::Distribution::make ; +sub make { + my($self) = @_; + $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id); + $self->get; + EXCUSE: { + my @e; + $self->{archived} eq "NO" and push @e, + "Is neither a tar nor a zip archive."; + + $self->{unwrapped} eq "NO" and push @e, + "had problems unarchiving. Please build manually"; + + exists $self->{writemakefile} && + $self->{writemakefile} eq "NO" and push @e, + "Had some problem writing Makefile"; + + defined $self->{'make'} and push @e, + "Has already been processed within this session"; + + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); + my $builddir = $self->dir; + chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!"); + $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; + + my $system; + if ($self->{'configure'}) { + $system = $self->{'configure'}; + } else { + my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; + my $switch = ""; +# This needs a handler that can be turned on or off: +# $switch = "-MExtUtils::MakeMaker ". +# "-Mops=:default,:filesys_read,:filesys_open,require,chdir" +# if $] > 5.00310; + $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}"; + } + { + local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; + my($ret,$pid); + $@ = ""; + if ($CPAN::Config->{inactivity_timeout}) { + eval { + alarm $CPAN::Config->{inactivity_timeout}; + local $SIG{CHLD} = sub { wait }; + if (defined($pid = fork)) { + if ($pid) { #parent + wait; + } else { #child + exec $system; + } + } else { + $CPAN::Frontend->myprint("Cannot fork: $!"); + return; + } + }; + alarm 0; + if ($@){ + kill 9, $pid; + waitpid $pid, 0; + $CPAN::Frontend->myprint($@); + $self->{writemakefile} = "NO - $@"; + $@ = ""; + return; + } + } else { + $ret = system($system); + if ($ret != 0) { + $self->{writemakefile} = "NO"; + return; + } + } + } + $self->{writemakefile} = "YES"; + return if $CPAN::Signal; + $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg}; + if (system($system) == 0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + $self->{'make'} = "YES"; + } else { + $self->{writemakefile} = "YES"; + $self->{'make'} = "NO"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); + } +} + +#-> sub CPAN::Distribution::test ; +sub test { + my($self) = @_; + $self->make; + return if $CPAN::Signal; + $CPAN::Frontend->myprint("Running make test\n"); + EXCUSE: { + my @e; + exists $self->{'make'} or push @e, + "Make had some problems, maybe interrupted? Won't test"; + + exists $self->{'make'} and + $self->{'make'} eq 'NO' and + push @e, "Oops, make had returned bad status"; + + exists $self->{'build_dir'} or push @e, "Has no own directory"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + chdir $self->{'build_dir'} or + Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") + if $CPAN::DEBUG; + my $system = join " ", $CPAN::Config->{'make'}, "test"; + if (system($system) == 0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + $self->{'make_test'} = "YES"; + } else { + $self->{'make_test'} = "NO"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); + } +} + +#-> sub CPAN::Distribution::clean ; +sub clean { + my($self) = @_; + $CPAN::Frontend->myprint("Running make clean\n"); + EXCUSE: { + my @e; + exists $self->{'build_dir'} or push @e, "Has no own directory"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + chdir $self->{'build_dir'} or + Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; + my $system = join " ", $CPAN::Config->{'make'}, "clean"; + if (system($system) == 0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + $self->force; + } else { + # Hmmm, what to do if make clean failed? + } +} + +#-> sub CPAN::Distribution::install ; +sub install { + my($self) = @_; + $self->test; + return if $CPAN::Signal; + $CPAN::Frontend->myprint("Running make install\n"); + EXCUSE: { + my @e; + exists $self->{'build_dir'} or push @e, "Has no own directory"; + + exists $self->{'make'} or push @e, + "Make had some problems, maybe interrupted? Won't install"; + + exists $self->{'make'} and + $self->{'make'} eq 'NO' and + push @e, "Oops, make had returned bad status"; + + push @e, "make test had returned bad status, ". + "won't install without force" + if exists $self->{'make_test'} and + $self->{'make_test'} eq 'NO' and + ! $self->{'force_update'}; + + exists $self->{'install'} and push @e, + $self->{'install'} eq "YES" ? + "Already done" : "Already tried without success"; + + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + chdir $self->{'build_dir'} or + Carp::croak("Couldn't chdir to $self->{'build_dir'}"); + $self->debug("Changed directory to $self->{'build_dir'}") + if $CPAN::DEBUG; + my $system = join(" ", $CPAN::Config->{'make'}, + "install", $CPAN::Config->{make_install_arg}); + my($pipe) = FileHandle->new("$system 2>&1 |"); + my($makeout) = ""; + while (<$pipe>){ + $CPAN::Frontend->myprint($_); + $makeout .= $_; + } + $pipe->close; + if ($?==0) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + $self->{'install'} = "YES"; + } else { + $self->{'install'} = "NO"; + $CPAN::Frontend->myprint(" $system -- NOT OK\n"); + if ($makeout =~ /permission/s && $> > 0) { + $CPAN::Frontend->myprint(qq{ You may have to su }. + qq{to root to install the package\n}); + } + } +} + +#-> sub CPAN::Distribution::dir ; +sub dir { + shift->{'build_dir'}; +} + +package CPAN::Bundle; + +#-> sub CPAN::Bundle::as_string ; +sub as_string { + my($self) = @_; + $self->contains; + $self->{INST_VERSION} = $self->inst_version; + return $self->SUPER::as_string; +} + +#-> sub CPAN::Bundle::contains ; +sub contains { + my($self) = @_; + my($parsefile) = $self->inst_file; + my($id) = $self->id; + $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; + unless ($parsefile) { + # Try to get at it in the cpan directory + $self->debug("no parsefile") if $CPAN::DEBUG; + Carp::confess "I don't know a $id" unless $self->{CPAN_FILE}; + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->{CPAN_FILE}); + $dist->get; + $self->debug($dist->as_string) if $CPAN::DEBUG; + my($todir) = $CPAN::Config->{'cpan_home'}; + my(@me,$from,$to,$me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + $me = MM->catfile(@me); + $from = $self->find_bundle_file($dist->{'build_dir'},$me); + $to = MM->catfile($todir,$me); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy($from, $to) + or Carp::confess("Couldn't copy $from to $to: $!"); + $parsefile = $to; + } + my @result; + my $fh = FileHandle->new; + local $/ = "\n"; + open($fh,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; + while (<$fh>) { + $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 : + /^=head1\s+CONTENTS/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, (split " ", $_, 2)[0]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = join ", ", @result; + $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; + @result; +} + +#-> sub CPAN::Bundle::find_bundle_file +sub find_bundle_file { + my($self,$where,$what) = @_; + $self->debug("where[$where]what[$what]") if $CPAN::DEBUG; + my $bu = MM->catfile($where,$what); + return $bu if -f $bu; + my $manifest = MM->catfile($where,"MANIFEST"); + unless (-f $manifest) { + require ExtUtils::Manifest; + my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + my $cwd = CPAN->$getcwd(); + chdir $where; + ExtUtils::Manifest::mkmanifest(); + chdir $cwd; + } + my $fh = FileHandle->new($manifest) + or Carp::croak("Couldn't open $manifest: $!"); + local($/) = "\n"; + while (<$fh>) { + next if /^\s*\#/; + my($file) = /(\S+)/; + if ($file =~ m|\Q$what\E$|) { + $bu = $file; + return MM->catfile($where,$bu); + } elsif ($what =~ s|Bundle/||) { # retry if she managed to + # have no Bundle directory + if ($file =~ m|\Q$what\E$|) { + $bu = $file; + return MM->catfile($where,$bu); + } + } + } + Carp::croak("Couldn't find a Bundle file in $where"); +} + +#-> sub CPAN::Bundle::inst_file ; +sub inst_file { + my($self) = @_; + my($me,$inst_file); + ($me = $self->id) =~ s/.*://; +## my(@me,$inst_file); +## @me = split /::/, $self->id; +## $me[-1] .= ".pm"; + $inst_file = MM->catfile($CPAN::Config->{'cpan_home'}, + "Bundle", "$me.pm"); +## "Bundle", @me); + return $self->{'INST_FILE'} = $inst_file if -f $inst_file; +# $inst_file = + $self->SUPER::inst_file; +# return $self->{'INST_FILE'} = $inst_file if -f $inst_file; +# return $self->{'INST_FILE'}; # even if undefined? +} + +#-> sub CPAN::Bundle::rematein ; +sub rematein { + my($self,$meth) = @_; + $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG; + my($id) = $self->id; + Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n" + unless $self->inst_file || $self->{CPAN_FILE}; + my($s); + for $s ($self->contains) { + my($type) = $s =~ m|/| ? 'CPAN::Distribution' : + $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module'; + if ($type eq 'CPAN::Distribution') { + $CPAN::Frontend->mywarn(qq{ +The Bundle }.$self->id.qq{ contains +explicitly a file $s. +}); + sleep 3; + } + $CPAN::META->instance($type,$s)->$meth(); + } +} + +#sub CPAN::Bundle::xs_file +sub xs_file { + # If a bundle contains another that contains an xs_file we have + # here, we just don't bother I suppose + return 0; +} + +#-> sub CPAN::Bundle::force ; +sub force { shift->rematein('force',@_); } +#-> sub CPAN::Bundle::get ; +sub get { shift->rematein('get',@_); } +#-> sub CPAN::Bundle::make ; +sub make { shift->rematein('make',@_); } +#-> sub CPAN::Bundle::test ; +sub test { shift->rematein('test',@_); } +#-> sub CPAN::Bundle::install ; +sub install { shift->rematein('install',@_); } +#-> sub CPAN::Bundle::clean ; +sub clean { shift->rematein('clean',@_); } + +#-> sub CPAN::Bundle::readme ; +sub readme { + my($self) = @_; + my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{ +No File found for bundle } . $self->id . qq{\n}), return; + $self->debug("self[$self] file[$file]") if $CPAN::DEBUG; + $CPAN::META->instance('CPAN::Distribution',$file)->readme; +} + +package CPAN::Module; + +#-> sub CPAN::Module::as_glimpse ; +sub as_glimpse { + my($self) = @_; + my(@m); + my $class = ref($self); + $class =~ s/^CPAN:://; + push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID}, + $self->cpan_file); + join "", @m; +} + +#-> sub CPAN::Module::as_string ; +sub as_string { + my($self) = @_; + my(@m); + CPAN->debug($self) if $CPAN::DEBUG; + my $class = ref($self); + $class =~ s/^CPAN:://; + local($^W) = 0; + push @m, $class, " id = $self->{ID}\n"; + my $sprintf = " %-12s %s\n"; + push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description}) + if $self->{description}; + my $sprintf2 = " %-12s %s (%s)\n"; + my($userid); + if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){ + my $author; + if ($author = CPAN::Shell->expand('Author',$userid)) { + push @m, sprintf( + $sprintf2, + 'CPAN_USERID', + $userid, + $author->fullname + ); + } + } + push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) + if $self->{CPAN_VERSION}; + push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE}) + if $self->{CPAN_FILE}; + my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n"; + my(%statd,%stats,%statl,%stati); + @statd{qw,? i c a b R M S,} = qw,unknown idea + pre-alpha alpha beta released mature standard,; + @stats{qw,? m d u n,} = qw,unknown mailing-list + developer comp.lang.perl.* none,; + @statl{qw,? p c + o,} = qw,unknown perl C C++ other,; + @stati{qw,? f r O,} = qw,unknown functions + references+ties object-oriented,; + $statd{' '} = 'unknown'; + $stats{' '} = 'unknown'; + $statl{' '} = 'unknown'; + $stati{' '} = 'unknown'; + push @m, sprintf( + $sprintf3, + 'DSLI_STATUS', + $self->{statd}, + $self->{stats}, + $self->{statl}, + $self->{stati}, + $statd{$self->{statd}}, + $stats{$self->{stats}}, + $statl{$self->{statl}}, + $stati{$self->{stati}} + ) if $self->{statd}; + my $local_file = $self->inst_file; + if ($local_file && ! exists $self->{MANPAGE}) { + my $fh = FileHandle->new($local_file) + or Carp::croak("Couldn't open $local_file: $!"); + my $inpod = 0; + my(@result); + local $/ = "\n"; + while (<$fh>) { + $inpod = /^=(?!head1\s+NAME)/ ? 0 : + /^=head1\s+NAME/ ? 1 : $inpod; + next unless $inpod; + next if /^=/; + next if /^\s+$/; + chomp; + push @result, $_; + } + close $fh; + $self->{MANPAGE} = join " ", @result; + } + my($item); + for $item (qw/MANPAGE CONTAINS/) { + push @m, sprintf($sprintf, $item, $self->{$item}) + if exists $self->{$item}; + } + push @m, sprintf($sprintf, 'INST_FILE', + $local_file || "(not installed)"); + push @m, sprintf($sprintf, 'INST_VERSION', + $self->inst_version) if $local_file; + join "", @m, "\n"; +} + +#-> sub CPAN::Module::cpan_file ; +sub cpan_file { + my $self = shift; + CPAN->debug($self->id) if $CPAN::DEBUG; + unless (defined $self->{'CPAN_FILE'}) { + CPAN::Index->reload; + } + if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){ + return $self->{'CPAN_FILE'}; + } elsif (exists $self->{'userid'} && defined $self->{'userid'}) { + my $fullname = $CPAN::META->instance(CPAN::Author, + $self->{'userid'})->fullname; + unless (defined $fullname) { + $CPAN::Frontend->mywarn(qq{Full name of author }. + qq{$self->{userid} not known}); + return "Contact Author $self->{userid}"; + } + return "Contact Author $self->{userid} ($fullname)" + } else { + return "N/A"; + } +} + +*name = \&cpan_file; + +#-> sub CPAN::Module::cpan_version ; +sub cpan_version { + my $self = shift; + $self->{'CPAN_VERSION'} = 'undef' + unless defined $self->{'CPAN_VERSION'}; # I believe this is + # always a bug in the + # index and should be + # reported as such, + # but usually I find + # out such an error + # and do not want to + # provoke too many + # bugreports + $self->{'CPAN_VERSION'}; +} + +#-> sub CPAN::Module::force ; +sub force { + my($self) = @_; + $self->{'force_update'}++; +} + +#-> sub CPAN::Module::rematein ; +sub rematein { + my($self,$meth) = @_; + $self->debug($self->id) if $CPAN::DEBUG; + my $cpan_file = $self->cpan_file; + return if $cpan_file eq "N/A"; + return if $cpan_file =~ /^Contact Author/; + my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file); + $pack->called_for($self->id); + $pack->force if exists $self->{'force_update'}; + $pack->$meth(); + delete $self->{'force_update'}; +} + +#-> sub CPAN::Module::readme ; +sub readme { shift->rematein('readme') } +#-> sub CPAN::Module::look ; +sub look { shift->rematein('look') } +#-> sub CPAN::Module::get ; +sub get { shift->rematein('get',@_); } +#-> sub CPAN::Module::make ; +sub make { shift->rematein('make') } +#-> sub CPAN::Module::test ; +sub test { shift->rematein('test') } +#-> sub CPAN::Module::install ; +sub install { + my($self) = @_; + my($doit) = 0; + my($latest) = $self->cpan_version; + $latest ||= 0; + my($inst_file) = $self->inst_file; + my($have) = 0; + if (defined $inst_file) { + $have = $self->inst_version; + } + if (1){ # A block for scoping $^W, the if is just for the visual + # appeal + local($^W)=0; + if ($inst_file + && + $have >= $latest + && + not exists $self->{'force_update'} + ) { + $CPAN::Frontend->myprint( $self->id. " is up to date.\n"); + } else { + $doit = 1; + } + } + $self->rematein('install') if $doit; +} +#-> sub CPAN::Module::clean ; +sub clean { shift->rematein('clean') } + +#-> sub CPAN::Module::inst_file ; +sub inst_file { + my($self) = @_; + my($dir,@packpath); + @packpath = split /::/, $self->{ID}; + $packpath[-1] .= ".pm"; + foreach $dir (@INC) { + my $pmfile = MM->catfile($dir,@packpath); + if (-f $pmfile){ + return $pmfile; + } + } + return; +} + +#-> sub CPAN::Module::xs_file ; +sub xs_file { + my($self) = @_; + my($dir,@packpath); + @packpath = split /::/, $self->{ID}; + push @packpath, $packpath[-1]; + $packpath[-1] .= "." . $Config::Config{'dlext'}; + foreach $dir (@INC) { + my $xsfile = MM->catfile($dir,'auto',@packpath); + if (-f $xsfile){ + return $xsfile; + } + } + return; +} + +#-> sub CPAN::Module::inst_version ; +sub inst_version { + my($self) = @_; + my $parsefile = $self->inst_file or return; + local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38; + my $have = MM->parse_version($parsefile) || "undef"; + $have =~ s/\s+//g; + $have; +} + +package CPAN; + +1; + +__END__ + +=head1 NAME + +CPAN - query, download and build perl modules from CPAN sites + +=head1 SYNOPSIS + +Interactive mode: + + perl -MCPAN -e shell; + +Batch mode: + + use CPAN; + + autobundle, clean, install, make, recompile, test + +=head1 DESCRIPTION + +The CPAN module is designed to automate the make and install of perl +modules and extensions. It includes some searching capabilities and +knows how to use Net::FTP or LWP (or lynx or an external ftp client) +to fetch the raw data from the net. + +Modules are fetched from one or more of the mirrored CPAN +(Comprehensive Perl Archive Network) sites and unpacked in a dedicated +directory. + +The CPAN module also supports the concept of named and versioned +'bundles' of modules. Bundles simplify the handling of sets of +related modules. See BUNDLES below. + +The package contains a session manager and a cache manager. There is +no status retained between sessions. The session manager keeps track +of what has been fetched, built and installed in the current +session. The cache manager keeps track of the disk space occupied by +the make processes and deletes excess space according to a simple FIFO +mechanism. + +All methods provided are accessible in a programmer style and in an +interactive shell style. + +=head2 Interactive Mode + +The interactive mode is entered by running + + perl -MCPAN -e shell + +which puts you into a readline interface. You will have most fun if +you install Term::ReadKey and Term::ReadLine to enjoy both history and +completion. + +Once you are on the command line, type 'h' and the rest should be +self-explanatory. + +The most common uses of the interactive modes are + +=over 2 + +=item Searching for authors, bundles, distribution files and modules + +There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m> +for each of the four categories and another, C<i> for any of the +mentioned four. Each of the four entities is implemented as a class +with slightly differing methods for displaying an object. + +Arguments you pass to these commands are either strings matching exact +the identification string of an object or regular expressions that are +then matched case-insensitively against various attributes of the +objects. The parser recognizes a regualar expression only if you +enclose it between two slashes. + +The principle is that the number of found objects influences how an +item is displayed. If the search finds one item, we display the result +of object-E<gt>as_string, but if we find more than one, we display +each as object-E<gt>as_glimpse. E.g. + + cpan> a ANDK + Author id = ANDK + EMAIL a.koenig@franz.ww.TU-Berlin.DE + FULLNAME Andreas König + + + cpan> a /andk/ + Author id = ANDK + EMAIL a.koenig@franz.ww.TU-Berlin.DE + FULLNAME Andreas König + + + cpan> a /and.*rt/ + Author ANDYD (Andy Dougherty) + Author MERLYN (Randal L. Schwartz) + +=item make, test, install, clean modules or distributions + +These commands do indeed exist just as written above. Each of them +takes any number of arguments and investigates for each what it might +be. Is it a distribution file (recognized by embedded slashes), this +file is being processed. Is it a module, CPAN determines the +distribution file where this module is included and processes that. + +Any C<make>, C<test>, and C<readme> are run unconditionally. A + + install <distribution_file> + +also is run unconditionally. But for + + install <module> + +CPAN checks if an install is actually needed for it and prints +I<Foo up to date> in case the module doesnE<39>t need to be updated. + +CPAN also keeps track of what it has done within the current session +and doesnE<39>t try to build a package a second time regardless if it +succeeded or not. The C<force > command takes as first argument the +method to invoke (currently: make, test, or install) and executes the +command from scratch. + +Example: + + cpan> install OpenGL + OpenGL is up to date. + cpan> force install OpenGL + Running make + OpenGL-0.4/ + OpenGL-0.4/COPYRIGHT + [...] + +=item readme, look module or distribution + +These two commands take only one argument, be it a module or a +distribution file. C<readme> displays the README of the associated +distribution file. C<Look> gets and untars (if not yet done) the +distribution file, changes to the appropriate directory and opens a +subshell process in that directory. + +=back + +=head2 CPAN::Shell + +The commands that are available in the shell interface are methods in +the package CPAN::Shell. If you enter the shell command, all your +input is split by the Text::ParseWords::shellwords() routine which +acts like most shells do. The first word is being interpreted as the +method to be called and the rest of the words are treated as arguments +to this method. Continuation lines are supported if a line ends with a +literal backslash. + +=head2 autobundle + +C<autobundle> writes a bundle file into the +C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains +a list of all modules that are both available from CPAN and currently +installed within @INC. The name of the bundle file is based on the +current date and a counter. + +=head2 recompile + +recompile() is a very special command in that it takes no argument and +runs the make/test/install cycle with brute force over all installed +dynamically loadable extensions (aka XS modules) with 'force' in +effect. Primary purpose of this command is to finish a network +installation. Imagine, you have a common source tree for two different +architectures. You decide to do a completely independent fresh +installation. You start on one architecture with the help of a Bundle +file produced earlier. CPAN installs the whole Bundle for you, but +when you try to repeat the job on the second architecture, CPAN +responds with a C<"Foo up to date"> message for all modules. So you +will be glad to run recompile in the second architecture and +youE<39>re done. + +Another popular use for C<recompile> is to act as a rescue in case your +perl breaks binary compatibility. If one of the modules that CPAN uses +is in turn depending on binary compatibility (so you cannot run CPAN +commands), then you should try the CPAN::Nox module for recovery. + +=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution + +Although it may be considered internal, the class hierarchie does +matter for both users and programmer. CPAN.pm deals with above +mentioned four classes, and all those classes share a set of +methods. It is a classical single polymorphism that is in effect. A +metaclass object registers all objects of all kinds and indexes them +with a string. The strings referencing objects have a separated +namespace (well, not completely separated): + + Namespace Class + + words containing a "/" (slash) Distribution + words starting with Bundle:: Bundle + everything else Module or Author + +Modules know their associated Distribution objects. They always refer +to the most recent official release. Developers may mark their +releases as unstable development versions (by inserting an underbar +into the visible version number), so not always is the default +distribution for a given module the really hottest and newest. If a +module Foo circulates on CPAN in both version 1.23 and 1.23_90, +CPAN.pm offers a convenient way to install version 1.23 by saying + + install Foo + +This would install the complete distribution file (say +BAR/Foo-1.23.tar.gz) with all accompanying material in there. But if +you would like to install version 1.23_90, you need to know where the +distribution file resides on CPAN relative to the authors/id/ +directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz, +so you would have to say + + install BAR/Foo-1.23_90.tar.gz + +The first example will be driven by an object of the class +CPAN::Module, the second by an object of class CPAN::Distribution. + +=head2 ProgrammerE<39>s interface + +If you do not enter the shell, the available shell commands are both +available as methods (C<CPAN::Shell-E<gt>install(...)>) and as +functions in the calling package (C<install(...)>). + +There's currently only one class that has a stable interface, +CPAN::Shell. All commands that are available in the CPAN shell are +methods of the class CPAN::Shell. Each of the commands that produce +listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the +IDs of all modules within the list. + +=over 2 + +=item expand($type,@things) + +The IDs of all objects available within a program are strings that can +be expanded to the corresponding real objects with the +C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a +list of CPAN::Module objects according to the C<@things> arguments +given. In scalar context it only returns the first element of the +list. + +=item Programming Examples + +This enables the programmer to do operations that combine +functionalities that are available in the shell. + + # install everything that is outdated on my disk: + perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)' + + # install my favorite programs if necessary: + for $mod (qw(Net::FTP MD5 Data::Dumper)){ + my $obj = CPAN::Shell->expand('Module',$mod); + $obj->install; + } + + # list all modules on my disk that have no VERSION number + for $mod (CPAN::Shell->expand("Module","/./")){ + next unless $mod->inst_file; + # MakeMaker convention for undefined $VERSION: + next unless $mod->inst_version eq "undef"; + print "No VERSION in ", $mod->id, "\n"; + } + +=back + +=head2 Methods in the four + +=head2 Cache Manager + +Currently the cache manager only keeps track of the build directory +($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that +deletes complete directories below C<build_dir> as soon as the size of +all directories there gets bigger than $CPAN::Config->{build_cache} +(in MB). The contents of this cache may be used for later +re-installations that you intend to do manually, but will never be +trusted by CPAN itself. This is due to the fact that the user might +use these directories for building modules on different architectures. + +There is another directory ($CPAN::Config->{keep_source_where}) where +the original distribution files are kept. This directory is not +covered by the cache manager and must be controlled by the user. If +you choose to have the same directory as build_dir and as +keep_source_where directory, then your sources will be deleted with +the same fifo mechanism. + +=head2 Bundles + +A bundle is just a perl module in the namespace Bundle:: that does not +define any functions or methods. It usually only contains documentation. + +It starts like a perl module with a package declaration and a $VERSION +variable. After that the pod section looks like any other pod with the +only difference, that I<one special pod section> exists starting with +(verbatim): + + =head1 CONTENTS + +In this pod section each line obeys the format + + Module_Name [Version_String] [- optional text] + +The only required part is the first field, the name of a module +(eg. Foo::Bar, ie. I<not> the name of the distribution file). The rest +of the line is optional. The comment part is delimited by a dash just +as in the man page header. + +The distribution of a bundle should follow the same convention as +other distributions. + +Bundles are treated specially in the CPAN package. If you say 'install +Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all +the modules in the CONTENTS section of the pod. You can install your +own Bundles locally by placing a conformant Bundle file somewhere into +your @INC path. The autobundle() command which is available in the +shell interface does that for you by including all currently installed +modules in a snapshot bundle file. + +=head2 Prerequisites + +If you have a local mirror of CPAN and can access all files with +"file:" URLs, then you only need a perl better than perl5.003 to run +this module. Otherwise Net::FTP is strongly recommended. LWP may be +required for non-UNIX systems or if your nearest CPAN site is +associated with an URL that is not C<ftp:>. + +If you have neither Net::FTP nor LWP, there is a fallback mechanism +implemented for an external ftp command or for an external lynx +command. + +This module presumes that all packages on CPAN + +=over 2 + +=item * + +declare their $VERSION variable in an easy to parse manner. This +prerequisite can hardly be relaxed because it consumes by far too much +memory to load all packages into the running program just to determine +the $VERSION variable . Currently all programs that are dealing with +version use something like this + + perl -MExtUtils::MakeMaker -le \ + 'print MM->parse_version($ARGV[0])' filename + +If you are author of a package and wonder if your $VERSION can be +parsed, please try the above method. + +=item * + +come as compressed or gzipped tarfiles or as zip files and contain a +Makefile.PL (well we try to handle a bit more, but without much +enthusiasm). + +=back + +=head2 Debugging + +The debugging of this module is pretty difficult, because we have +interferences of the software producing the indices on CPAN, of the +mirroring process on CPAN, of packaging, of configuration, of +synchronicity, and of bugs within CPAN.pm. + +In interactive mode you can try "o debug" which will list options for +debugging the various parts of the package. The output may not be very +useful for you as it's just a byproduct of my own testing, but if you +have an idea which part of the package may have a bug, it's sometimes +worth to give it a try and send me more specific output. You should +know that "o debug" has built-in completion support. + +=head2 Floppy, Zip, and all that Jazz + +CPAN.pm works nicely without network too. If you maintain machines +that are not networked at all, you should consider working with file: +URLs. Of course, you have to collect your modules somewhere first. So +you might use CPAN.pm to put together all you need on a networked +machine. Then copy the $CPAN::Config->{keep_source_where} (but not +$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind +of a personal CPAN. CPAN.pm on the non-networked machines works nicely +with this floppy. + +=head1 CONFIGURATION + +When the CPAN module is installed a site wide configuration file is +created as CPAN/Config.pm. The default values defined there can be +overridden in another configuration file: CPAN/MyConfig.pm. You can +store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because +$HOME/.cpan is added to the search path of the CPAN module before the +use() or require() statements. + +Currently the following keys in the hash reference $CPAN::Config are +defined: + + build_cache size of cache for directories to build modules + build_dir locally accessible directory to build modules + index_expire after how many days refetch index files + cpan_home local directory reserved for this package + gzip location of external program gzip + inactivity_timeout breaks interactive Makefile.PLs after that + many seconds inactivity. Set to 0 to never break. + inhibit_startup_message + if true, does not print the startup message + keep_source keep the source in a local directory? + keep_source_where where keep the source (if we do) + make location of external program make + make_arg arguments that should always be passed to 'make' + make_install_arg same as make_arg for 'make install' + makepl_arg arguments passed to 'perl Makefile.PL' + pager location of external program more (or any pager) + tar location of external program tar + unzip location of external program unzip + urllist arrayref to nearby CPAN sites (or equivalent locations) + +You can set and query each of these options interactively in the cpan +shell with the command set defined within the C<o conf> command: + +=over 2 + +=item o conf E<lt>scalar optionE<gt> + +prints the current value of the I<scalar option> + +=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt> + +Sets the value of the I<scalar option> to I<value> + +=item o conf E<lt>list optionE<gt> + +prints the current value of the I<list option> in MakeMaker's +neatvalue format. + +=item o conf E<lt>list optionE<gt> [shift|pop] + +shifts or pops the array in the I<list option> variable + +=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt> + +works like the corresponding perl commands. + +=back + +=head2 CD-ROM support + +The C<urllist> parameter of the configuration table contains a list of +URLs that are to be used for downloading. If the list contains any +C<file> URLs, CPAN always tries to get files from there first. This +feature is disabled for index files. So the recommendation for the +owner of a CD-ROM with CPAN contents is: include your local, possibly +outdated CD-ROM as a C<file> URL at the end of urllist, e.g. + + o conf urllist push file://localhost/CDROM/CPAN + +CPAN.pm will then fetch the index files from one of the CPAN sites +that come at the beginning of urllist. It will later check for each +module if there is a local copy of the most recent version. + +=head1 SECURITY + +There's no strong security layer in CPAN.pm. CPAN.pm helps you to +install foreign, unmasked, unsigned code on your machine. We compare +to a checksum that comes from the net just as the distribution file +itself. If somebody has managed to tamper with the distribution file, +they may have as well tampered with the CHECKSUMS file. Future +development will go towards strong authentification. + +=head1 EXPORT + +Most functions in package CPAN are exported per default. The reason +for this is that the primary use is intended for the cpan shell or for +oneliners. + +=head1 BUGS + +we should give coverage for _all_ of the CPAN and not just the +PAUSE part, right? In this discussion CPAN and PAUSE have become +equal -- but they are not. PAUSE is authors/ and modules/. CPAN is +PAUSE plus the clpa/, doc/, misc/, ports/, src/, scripts/. + +Future development should be directed towards a better integration of +the other parts. + +=head1 AUTHOR + +Andreas König E<lt>a.koenig@mind.deE<gt> + +=head1 SEE ALSO + +perl(1), CPAN::Nox(3) + +=cut + diff --git a/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm b/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm new file mode 100644 index 00000000000..ae09240c0f3 --- /dev/null +++ b/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm @@ -0,0 +1,402 @@ +package CPAN::Mirrored::By; + +sub new { + my($self,@arg) = @_; + bless [@arg], $self; +} +sub continent { shift->[0] } +sub country { shift->[1] } +sub url { shift->[2] } + +package CPAN::FirstTime; + +use strict; +use ExtUtils::MakeMaker qw(prompt); +use FileHandle (); +use File::Path (); +use vars qw($VERSION); +$VERSION = substr q$Revision: 1.1 $, 10; + +=head1 NAME + +CPAN::FirstTime - Utility for CPAN::Config file Initialization + +=head1 SYNOPSIS + +CPAN::FirstTime::init() + +=head1 DESCRIPTION + +The init routine asks a few questions and writes a CPAN::Config +file. Nothing special. + +=cut + + +sub init { + my($configpm) = @_; + use Config; + require CPAN::Nox; + eval {require CPAN::Config;}; + $CPAN::Config ||= {}; + local($/) = "\n"; + local($\) = ""; + + my($ans,$default,$local,$cont,$url,$expected_size); + + # + # Files, directories + # + + print qq{ +The CPAN module needs a directory of its own to cache important +index files and maybe keep a temporary mirror of CPAN files. This may +be a site-wide directory or a personal directory. +}; + + my $cpan_home = $CPAN::Config->{cpan_home} || MM->catdir($ENV{HOME}, ".cpan"); + if (-d $cpan_home) { + print qq{ + +I see you already have a directory + $cpan_home +Shall we use it as the general CPAN build and cache directory? + +}; + } else { + print qq{ + +First of all, I\'d like to create this directory. Where? + +}; + } + + $default = $cpan_home; + while ($ans = prompt("CPAN build and cache directory?",$default)) { + File::Path::mkpath($ans); # dies if it can't + if (-d $ans && -w _) { + last; + } else { + warn "Couldn't find directory $ans + or directory is not writable. Please retry.\n"; + } + } + $CPAN::Config->{cpan_home} = $ans; + + print qq{ + +If you want, I can keep the source files after a build in the cpan +home directory. If you choose so then future builds will take the +files from there. If you don\'t want to keep them, answer 0 to the +next question. + +}; + + $CPAN::Config->{keep_source_where} = MM->catdir($CPAN::Config->{cpan_home},"sources"); + $CPAN::Config->{build_dir} = MM->catdir($CPAN::Config->{cpan_home},"build"); + + # + # Cache size, Index expire + # + + print qq{ + +How big should the disk cache be for keeping the build directories +with all the intermediate files? + +}; + + $default = $CPAN::Config->{build_cache} || 10; + $ans = prompt("Cache size for build directory (in MB)?", $default); + $CPAN::Config->{build_cache} = $ans; + + # XXX This the time when we refetch the index files (in days) + $CPAN::Config->{'index_expire'} = 1; + + # + # External programs + # + + print qq{ + +The CPAN module will need a few external programs to work +properly. Please correct me, if I guess the wrong path for a program. +Don\'t panic if you do not have some of them, just press ENTER for +those. + +}; + + my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'}; + my $prog; + for $prog (qw/gzip tar unzip make lynx ncftp ftp/){ + my $path = $CPAN::Config->{$prog} || ""; + if (MM->file_name_is_absolute($path)) { + warn "Warning: configured $path does not exist\n" unless -e $path; + $path = ""; + } else { + $path = ''; + } + $path ||= find_exe($prog,[@path]); + warn "Warning: $prog not found in PATH\n" unless -e $path; + $ans = prompt("Where is your $prog program?",$path) || $path; + $CPAN::Config->{$prog} = $ans; + } + my $path = $CPAN::Config->{'pager'} || + $ENV{PAGER} || find_exe("less",[@path]) || + find_exe("more",[@path]) || "more"; + $ans = prompt("What is your favorite pager program?",$path); + $CPAN::Config->{'pager'} = $ans; + $path = $CPAN::Config->{'shell'}; + if (MM->file_name_is_absolute($path)) { + warn "Warning: configured $path does not exist\n" unless -e $path; + $path = ""; + } + $path ||= $ENV{SHELL}; + $ans = prompt("What is your favorite shell?",$path); + $CPAN::Config->{'shell'} = $ans; + + # + # Arguments to make etc. + # + + print qq{ + +Every Makefile.PL is run by perl in a separate process. Likewise we +run \'make\' and \'make install\' in processes. If you have any parameters +\(e.g. PREFIX, INSTALLPRIVLIB, UNINST or the like\) you want to pass to +the calls, please specify them here. + +If you don\'t understand this question, just press ENTER. + +}; + + $default = $CPAN::Config->{makepl_arg} || ""; + $CPAN::Config->{makepl_arg} = + prompt("Parameters for the 'perl Makefile.PL' command?",$default); + $default = $CPAN::Config->{make_arg} || ""; + $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?",$default); + + $default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || ""; + $CPAN::Config->{make_install_arg} = + prompt("Parameters for the 'make install' command?",$default); + + # + # Alarm period + # + + print qq{ + +Sometimes you may wish to leave the processes run by CPAN alone +without caring about them. As sometimes the Makefile.PL contains +question you\'re expected to answer, you can set a timer that will +kill a 'perl Makefile.PL' process after the specified time in seconds. + +If you set this value to 0, these processes will wait forever. This is +the default and recommended setting. + +}; + + $default = $CPAN::Config->{inactivity_timeout} || 0; + $CPAN::Config->{inactivity_timeout} = + prompt("Timeout for inacivity during Makefile.PL?",$default); + + + # + # MIRRORED.BY + # + + $local = 'MIRRORED.BY'; + $local = MM->catfile($CPAN::Config->{keep_source_where},"MIRRORED.BY") unless -f $local; + if (@{$CPAN::Config->{urllist}||[]}) { + print qq{ +I found a list of URLs in CPAN::Config and will use this. +You can change it later with the 'o conf urllist' command. + +} + } elsif ( + -s $local + && + -M $local < 30 + ) { + read_mirrored_by($local); + } else { + $CPAN::Config->{urllist} ||= []; + while (! @{$CPAN::Config->{urllist}}) { + my($input) = prompt(qq{ +We need to know the URL of your favorite CPAN site. +Please enter it here:}); + $input =~ s/\s//g; + next unless $input; + my($wanted) = "MIRRORED.BY"; + print qq{ +Testing "$input" ... +}; + push @{$CPAN::Config->{urllist}}, $input; + CPAN::FTP->localize($wanted,$local,"force"); + if (-s $local) { + print qq{ +"$input" seems to work +}; + } else { + my $ans = prompt(qq{$input doesn\'t seem to work. Keep it in the list?},"n"); + last unless $ans =~ /^n/i; + pop @{$CPAN::Config->{urllist}}; + } + } + } + + unless (@{$CPAN::Config->{'wait_list'}||[]}) { + print qq{ + +WAIT support is available as a Plugin. You need the CPAN::WAIT module +to actually use it. But we need to know your favorite WAIT server. If +you don\'t know a WAIT server near you, just press ENTER. + +}; + $default = "wait://ls6.informatik.uni-dortmund.de:1404"; + $ans = prompt("Your favorite WAIT server?\n ",$default); + push @{$CPAN::Config->{'wait_list'}}, $ans; + } + + print qq{ + +If you\'re accessing the net via proxies, you can specify them in the +CPAN configuration or via environment variables. The variable in +the \$CPAN::Config takes precedence. + +}; + + for (qw/ftp_proxy http_proxy no_proxy/) { + $default = $CPAN::Config->{$_} || $ENV{$_}; + $CPAN::Config->{$_} = prompt("Your $_?",$default); + } + + # We don't ask that now, it will be noticed in time, won't it? + $CPAN::Config->{'inhibit_startup_message'} = 0; + $CPAN::Config->{'getcwd'} = 'cwd'; + + print "\n\n"; + CPAN::Config->commit($configpm); +} + +sub find_exe { + my($exe,$path) = @_; + my($dir); + #warn "in find_exe exe[$exe] path[@$path]"; + for $dir (@$path) { + my $abs = MM->catfile($dir,$exe); + if (MM->maybe_command($abs)) { + return $abs; + } + } +} + +sub read_mirrored_by { + my($local) = @_; + my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location); + my $fh = FileHandle->new; + $fh->open($local) or die "Couldn't open $local: $!"; + while (<$fh>) { + ($host) = /^([\w\.\-]+)/ unless defined $host; + next unless defined $host; + next unless /\s+dst_(dst|location)/; + /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and + ($continent, $country) = @location[-1,-2]; + $continent =~ s/\s\(.*//; + /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1; + next unless $host && $dst && $continent && $country; + $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst); + undef $host; + $dst=$continent=$country=""; + } + $fh->close; + $CPAN::Config->{urllist} ||= []; + if ($expected_size = @{$CPAN::Config->{urllist}}) { + for $url (@{$CPAN::Config->{urllist}}) { + # sanity check, scheme+colon, not "q" there: + next unless $url =~ /^\w+:\/./; + $all{"[From previous setup]"}{"found URL"}{$url}=CPAN::Mirrored::By->new('[From previous setup]','found URL',$url); + } + $CPAN::Config->{urllist} = []; + } else { + $expected_size = 6; + } + + print qq{ + +Now we need to know, where your favorite CPAN sites are located. Push +a few sites onto the array (just in case the first on the array won\'t +work). If you are mirroring CPAN to your local workstation, specify a +file: URL. + +You can enter the number in front of the URL on the next screen, a +file:, ftp: or http: URL, or "q" to finish selecting. + +}; + + $ans = prompt("Press RETURN to continue"); + my $other; + $ans = $other = ""; + my(%seen); + + my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null"; + while () { + my(@valid,$previous_best); + my $fh = FileHandle->new; + $fh->open($pipe); + { + my($cont,$country,$url,$item); + my(@cont) = sort keys %all; + for $cont (@cont) { + $fh->print(" $cont\n"); + for $country (sort {lc $a cmp lc $b} keys %{$all{$cont}}) { + for $url (sort {lc $a cmp lc $b} keys %{$all{$cont}{$country}}) { + my $t = sprintf( + " %-18s (%2d) %s\n", + $country, + ++$item, + $url + ); + if ($cont =~ /^\[/) { + $previous_best ||= $item; + } + push @valid, $all{$cont}{$country}{$url}; + $fh->print($t); + } + } + } + } + $fh->close; + $previous_best ||= 1; + $default = + @{$CPAN::Config->{urllist}} >= $expected_size ? "q" : $previous_best; + $ans = prompt( + "\nSelect an$other ftp or file URL or a number (q to finish)", + $default + ); + my $sel; + if ($ans =~ /^\d/) { + my $this = $valid[$ans-1]; + my($con,$cou,$url) = ($this->continent,$this->country,$this->url); + push @{$CPAN::Config->{urllist}}, $url unless $seen{$url}++; + delete $all{$con}{$cou}{$url}; + # print "Was a number [$ans] con[$con] cou[$cou] url[$url]\n"; + } elsif (@{$CPAN::Config->{urllist}} && $ans =~ /^q/i) { + last; + } else { + $ans =~ s|/?$|/|; # has to end with one slash + $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file: + if ($ans =~ /^\w+:\/./) { + push @{$CPAN::Config->{urllist}}, $ans unless $seen{$ans}++; + } else { + print qq{"$ans" doesn\'t look like an URL at first sight. +I\'ll ignore it for now. You can add it to lib/CPAN/Config.pm +later and report a bug in my Makefile.PL to me (andreas koenig). +Thanks.\n}; + } + } + $other ||= "other"; + } +} + +1; diff --git a/gnu/usr.bin/perl/lib/CPAN/Nox.pm b/gnu/usr.bin/perl/lib/CPAN/Nox.pm new file mode 100644 index 00000000000..23ad760b87b --- /dev/null +++ b/gnu/usr.bin/perl/lib/CPAN/Nox.pm @@ -0,0 +1,33 @@ +BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;} + +use CPAN; + +$CPAN::META->has_inst('MD5','no'); +$CPAN::META->has_inst('LWP','no'); +@EXPORT = @CPAN::EXPORT; + +*AUTOLOAD = \&CPAN::AUTOLOAD; + +=head1 NAME + +CPAN::Nox - Wrapper around CPAN.pm without using any XS module + +=head1 SYNOPSIS + +Interactive mode: + + perl -MCPAN::Nox -e shell; + +=head1 DESCRIPTION + +This package has the same functionality as CPAN.pm, but tries to +prevent the usage of compiled extensions during it's own +execution. It's primary purpose is a rescue in case you upgraded perl +and broke binary compatibility somehow. + +=head1 SEE ALSO + +CPAN(3) + +=cut + diff --git a/gnu/usr.bin/perl/lib/Class/Struct.pm b/gnu/usr.bin/perl/lib/Class/Struct.pm new file mode 100644 index 00000000000..09ab196254e --- /dev/null +++ b/gnu/usr.bin/perl/lib/Class/Struct.pm @@ -0,0 +1,479 @@ +package Class::Struct; + +## See POD after __END__ + +require 5.002; + +use strict; +use vars qw(@ISA @EXPORT); + +use Carp; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(struct); + +## Tested on 5.002 and 5.003 without class membership tests: +my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); + +my $print = 0; +sub printem { + if (@_) { $print = shift } + else { $print++ } +} + +{ + package Class::Struct::Tie_ISA; + + sub TIEARRAY { + my $class = shift; + return bless [], $class; + } + + sub STORE { + my ($self, $index, $value) = @_; + Class::Struct::_subclass_error(); + } + + sub FETCH { + my ($self, $index) = @_; + $self->[$index]; + } + + sub DESTROY { } +} + +sub struct { + + # Determine parameter list structure, one of: + # struct( class => [ element-list ]) + # struct( class => { element-list }) + # struct( element-list ) + # Latter form assumes current package name as struct name. + + my ($class, @decls); + my $base_type = ref $_[1]; + if ( $base_type eq 'HASH' ) { + $class = shift; + @decls = %{shift()}; + _usage_error() if @_; + } + elsif ( $base_type eq 'ARRAY' ) { + $class = shift; + @decls = @{shift()}; + _usage_error() if @_; + } + else { + $base_type = 'ARRAY'; + $class = (caller())[0]; + @decls = @_; + } + _usage_error() if @decls % 2 == 1; + + # Ensure we are not, and will not be, a subclass. + + my $isa = do { + no strict 'refs'; + \@{$class . '::ISA'}; + }; + _subclass_error() if @$isa; + tie @$isa, 'Class::Struct::Tie_ISA'; + + # Create constructor. + + croak "function 'new' already defined in package $class" + if do { no strict 'refs'; defined &{$class . "::new"} }; + + my @methods = (); + my %refs = (); + my %arrays = (); + my %hashes = (); + my %classes = (); + my $got_class = 0; + my $out = ''; + + $out = "{\n package $class;\n use Carp;\n sub new {\n"; + + my $cnt = 0; + my $idx = 0; + my( $cmt, $name, $type, $elem ); + + if( $base_type eq 'HASH' ){ + $out .= " my(\$r) = {};\n"; + $cmt = ''; + } + elsif( $base_type eq 'ARRAY' ){ + $out .= " my(\$r) = [];\n"; + } + while( $idx < @decls ){ + $name = $decls[$idx]; + $type = $decls[$idx+1]; + push( @methods, $name ); + if( $base_type eq 'HASH' ){ + $elem = "{'$name'}"; + } + elsif( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + $cmt = " # $name"; + } + if( $type =~ /^\*(.)/ ){ + $refs{$name}++; + $type = $1; + } + if( $type eq '@' ){ + $out .= " \$r->$elem = [];$cmt\n"; + $arrays{$name}++; + } + elsif( $type eq '%' ){ + $out .= " \$r->$elem = {};$cmt\n"; + $hashes{$name}++; + } + elsif ( $type eq '$') { + $out .= " \$r->$elem = undef;$cmt\n"; + } + elsif( $type =~ /^\w+(?:::\w+)*$/ ){ + $out .= " \$r->$elem = '${type}'->new();$cmt\n"; + $classes{$name} = $type; + $got_class = 1; + } + else{ + croak "'$type' is not a valid struct element type"; + } + $idx += 2; + } + $out .= " bless \$r;\n }\n"; + + # Create accessor methods. + + my( $pre, $pst, $sel ); + $cnt = 0; + foreach $name (@methods){ + if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { + carp "function '$name' already defined, overrides struct accessor method" + if $^W; + } + else { + $pre = $pst = $cmt = $sel = ''; + if( defined $refs{$name} ){ + $pre = "\\("; + $pst = ")"; + $cmt = " # returns ref"; + } + $out .= " sub $name {$cmt\n my \$r = shift;\n"; + if( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + } + elsif( $base_type eq 'HASH' ){ + $elem = "{'$name'}"; + } + if( defined $arrays{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return $pre\$r->$elem$pst;\n"; + $sel = "->[\$i]"; + } + elsif( defined $hashes{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return $pre\$r->$elem$pst;\n"; + $sel = "->{\$i}"; + } + elsif( defined $classes{$name} ){ + if ( $CHECK_CLASS_MEMBERSHIP ) { + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$type');\n"; + } + } + $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; + $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; + $out .= " }\n"; + } + } + $out .= "}\n1;\n"; + + print $out if $print; + my $result = eval $out; + carp $@ if $@; +} + +sub _usage_error { + confess "struct usage error"; +} + +sub _subclass_error { + croak 'struct class cannot be a subclass (@ISA not allowed)'; +} + +1; # for require + + +__END__ + +=head1 NAME + +Class::Struct - declare struct-like datatypes as Perl classes + +=head1 SYNOPSIS + + use Class::Struct; + # declare struct, based on array: + struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]); + # declare struct, based on hash: + struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }); + + package CLASS_NAME; + use Class::Struct; + # declare struct, based on array, implicit class name: + struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); + + + package Myobj; + use Class::Struct; + # declare struct with four types of elements: + struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); + + $obj = new Myobj; # constructor + + # scalar type accessor: + $element_value = $obj->s; # element value + $obj->s('new value'); # assign to element + + # array type accessor: + $ary_ref = $obj->a; # reference to whole array + $ary_element_value = $obj->a(2); # array element value + $obj->a(2, 'new value'); # assign to array element + + # hash type accessor: + $hash_ref = $obj->h; # reference to whole hash + $hash_element_value = $obj->h('x'); # hash element value + $obj->h('x', 'new value'); # assign to hash element + + # class type accessor: + $element_value = $obj->c; # object reference + $obj->c->method(...); # call method of object + $obj->c(new My_Other_Class); # assign a new object + + +=head1 DESCRIPTION + +C<Class::Struct> exports a single function, C<struct>. +Given a list of element names and types, and optionally +a class name, C<struct> creates a Perl 5 class that implements +a "struct-like" data structure. + +The new class is given a constructor method, C<new>, for creating +struct objects. + +Each element in the struct data has an accessor method, which is +used to assign to the element and to fetch its value. The +default accessor can be overridden by declaring a C<sub> of the +same name in the package. (See Example 2.) + +Each element's type can be scalar, array, hash, or class. + + +=head2 The C<struct()> function + +The C<struct> function has three forms of parameter-list. + + struct( CLASS_NAME => [ ELEMENT_LIST ]); + struct( CLASS_NAME => { ELEMENT_LIST }); + struct( ELEMENT_LIST ); + +The first and second forms explicitly identify the name of the +class being created. The third form assumes the current package +name as the class name. + +An object of a class created by the first and third forms is +based on an array, whereas an object of a class created by the +second form is based on a hash. The array-based forms will be +somewhat faster and smaller; the hash-based forms are more +flexible. + +The class created by C<struct> must not be a subclass of another +class other than C<UNIVERSAL>. + +A function named C<new> must not be explicitly defined in a class +created by C<struct>. + +The I<ELEMENT_LIST> has the form + + NAME => TYPE, ... + +Each name-type pair declares one element of the struct. Each +element name will be defined as an accessor method unless a +method by that name is explicitly defined; in the latter case, a +warning is issued if the warning flag (B<-w>) is set. + + +=head2 Element Types and Accessor Methods + +The four element types -- scalar, array, hash, and class -- are +represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name -- +optionally preceded by a C<'*'>. + +The accessor method provided by C<struct> for an element depends +on the declared type of the element. + +=over + +=item Scalar (C<'$'> or C<'*$'>) + +The element is a scalar, and is initialized to C<undef>. + +The accessor's argument, if any, is assigned to the element. + +If the element type is C<'$'>, the value of the element (after +assignment) is returned. If the element type is C<'*$'>, a reference +to the element is returned. + +=item Array (C<'@'> or C<'*@'>) + +The element is an array, initialized to C<()>. + +With no argument, the accessor returns a reference to the +element's whole array. + +With one or two arguments, the first argument is an index +specifying one element of the array; the second argument, if +present, is assigned to the array element. If the element type +is C<'@'>, the accessor returns the array element value. If the +element type is C<'*@'>, a reference to the array element is +returned. + +=item Hash (C<'%'> or C<'*%'>) + +The element is a hash, initialized to C<()>. + +With no argument, the accessor returns a reference to the +element's whole hash. + +With one or two arguments, the first argument is a key specifying +one element of the hash; the second argument, if present, is +assigned to the hash element. If the element type is C<'%'>, the +accessor returns the hash element value. If the element type is +C<'*%'>, a reference to the hash element is returned. + +=item Class (C<'Class_Name'> or C<'*Class_Name'>) + +The element's value must be a reference blessed to the named +class or to one of its subclasses. The element is initialized to +the result of calling the C<new> constructor of the named class. + +The accessor's argument, if any, is assigned to the element. The +accessor will C<croak> if this is not an appropriate object +reference. + +If the element type does not start with a C<'*'>, the accessor +returns the element value (after assignment). If the element type +starts with a C<'*'>, a reference to the element itself is returned. + +=back + +=head1 EXAMPLES + +=over + +=item Example 1 + +Giving a struct element a class type that is also a struct is how +structs are nested. Here, C<timeval> represents a time (seconds and +microseconds), and C<rusage> has two elements, each of which is of +type C<timeval>. + + use Class::Struct; + + struct( rusage => { + ru_utime => timeval, # seconds + ru_stime => timeval, # microseconds + }); + + struct( timeval => [ + tv_secs => '$', + tv_usecs => '$', + ]); + + # create an object: + my $t = new rusage; + # $t->ru_utime and $t->ru_stime are objects of type timeval. + + # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec. + $t->ru_utime->tv_secs(100); + $t->ru_utime->tv_usecs(0); + $t->ru_stime->tv_secs(5); + $t->ru_stime->tv_usecs(0); + + +=item Example 2 + +An accessor function can be redefined in order to provide +additional checking of values, etc. Here, we want the C<count> +element always to be nonnegative, so we redefine the C<count> +accessor accordingly. + + package MyObj; + use Class::Struct; + + # declare the struct + struct ( 'MyObj', { count => '$', stuff => '%' } ); + + # override the default accessor method for 'count' + sub count { + my $self = shift; + if ( @_ ) { + die 'count must be nonnegative' if $_[0] < 0; + $self->{'count'} = shift; + warn "Too many args to count" if @_; + } + return $self->{'count'}; + } + + package main; + $x = new MyObj; + print "\$x->count(5) = ", $x->count(5), "\n"; + # prints '$x->count(5) = 5' + + print "\$x->count = ", $x->count, "\n"; + # prints '$x->count = 5' + + print "\$x->count(-5) = ", $x->count(-5), "\n"; + # dies due to negative argument! + + +=head1 Author and Modification History + + +Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02. + + members() function removed. + Documentation corrected and extended. + Use of struct() in a subclass prohibited. + User definition of accessor allowed. + Treatment of '*' in element types corrected. + Treatment of classes as element types corrected. + Class name to struct() made optional. + Diagnostic checks added. + + +Originally C<Class::Template> by Dean Roehrich. + + # Template.pm --- struct/member template builder + # 12mar95 + # Dean Roehrich + # + # changes/bugs fixed since 28nov94 version: + # - podified + # changes/bugs fixed since 21nov94 version: + # - Fixed examples. + # changes/bugs fixed since 02sep94 version: + # - Moved to Class::Template. + # changes/bugs fixed since 20feb94 version: + # - Updated to be a more proper module. + # - Added "use strict". + # - Bug in build_methods, was using @var when @$var needed. + # - Now using my() rather than local(). + # + # Uses perl5 classes to create nested data types. + # This is offered as one implementation of Tom Christiansen's "structs.pl" + # idea. + +=cut diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Command.pm b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm new file mode 100644 index 00000000000..d37d0f3c25e --- /dev/null +++ b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm @@ -0,0 +1,208 @@ +package ExtUtils::Command; +use strict; +# use AutoLoader; +use Carp; +use File::Copy; +use File::Compare; +use File::Basename; +use File::Path qw(rmtree); +require Exporter; +use vars qw(@ISA @EXPORT $VERSION); +@ISA = qw(Exporter); +@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f); +$VERSION = '1.01'; + +=head1 NAME + +ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. + +=head1 SYNOPSIS + + perl -MExtUtils::Command -e cat files... > destination + perl -MExtUtils::Command -e mv source... destination + perl -MExtUtils::Command -e cp source... destination + perl -MExtUtils::Command -e touch files... + perl -MExtUtils::Command -e rm_f file... + perl -MExtUtils::Command -e rm_rf directories... + perl -MExtUtils::Command -e mkpath directories... + perl -MExtUtils::Command -e eqtime source destination + perl -MExtUtils::Command -e chmod mode files... + perl -MExtUtils::Command -e test_f file + +=head1 DESCRIPTION + +The module is used in Win32 port to replace common UNIX commands. +Most commands are wrapers on generic modules File::Path and File::Basename. + +=over 4 + +=cut + +sub expand_wildcards +{ + @ARGV = map(/[\*\?]/ ? glob($_) : $_,@ARGV); +} + +=item cat + +Concatenates all files mentioned on command line to STDOUT. + +=cut + +sub cat () +{ + expand_wildcards(); + print while (<>); +} + +=item eqtime src dst + +Sets modified time of dst to that of src + +=cut + +sub eqtime +{ + my ($src,$dst) = @ARGV; + open(F,">$dst"); + close(F); + utime((stat($src))[8,9],$dst); +} + +=item rm_f files.... + +Removes directories - recursively (even if readonly) + +=cut + +sub rm_rf +{ + rmtree([grep -e $_,expand_wildcards()],0,0); +} + +=item rm_f files.... + +Removes files (even if readonly) + +=cut + +sub rm_f +{ + foreach (expand_wildcards()) + { + next unless -f $_; + next if unlink($_); + chmod(0777,$_); + next if unlink($_); + carp "Cannot delete $_:$!"; + } +} + +=item touch files ... + +Makes files exist, with current timestamp + +=cut + +sub touch +{ + expand_wildcards(); + while (@ARGV) + { + my $file = shift(@ARGV); + open(FILE,">>$file") || die "Cannot write $file:$!"; + close(FILE); + } +} + +=item mv source... destination + +Moves source to destination. +Multiple sources are allowed if destination is an existing directory. + +=cut + +sub mv +{ + my $dst = pop(@ARGV); + expand_wildcards(); + croak("Too many arguments") if (@ARGV > 1 && ! -d $dst); + while (@ARGV) + { + my $src = shift(@ARGV); + move($src,$dst); + } +} + +=item cp source... destination + +Copies source to destination. +Multiple sources are allowed if destination is an existing directory. + +=cut + +sub cp +{ + my $dst = pop(@ARGV); + expand_wildcards(); + croak("Too many arguments") if (@ARGV > 1 && ! -d $dst); + while (@ARGV) + { + my $src = shift(@ARGV); + copy($src,$dst); + } +} + +=item chmod mode files... + +Sets UNIX like permissions 'mode' on all the files. + +=cut + +sub chmod +{ + my $mode = shift(@ARGV); + chmod($mode,expand_wildcards()) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; +} + +=item mkpath directory... + +Creates directory, including any parent directories. + +=cut + +sub mkpath +{ + File::Path::mkpath([expand_wildcards()],1,0777); +} + +=item test_f file + +Tests if a file exists + +=cut + +sub test_f +{ + exit !-f shift(@ARGV); +} + +1; +__END__ + +=back + +=head1 BUGS + +Should probably be Auto/Self loaded. + +=head1 SEE ALSO + +ExtUtils::MakeMaker, ExtUtils::MM_Unix, ExtUtils::MM_Win32 + +=head1 AUTHOR + +Nick Ing-Simmons <F<nick@ni-s.u-net.com>>. + +=cut + diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm new file mode 100644 index 00000000000..04ce1763da7 --- /dev/null +++ b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm @@ -0,0 +1,486 @@ +# $Id: Embed.pm,v 1.2501 $ +require 5.002; + +package ExtUtils::Embed; +require Exporter; +require FileHandle; +use Config; +use Getopt::Std; + +#Only when we need them +#require ExtUtils::MakeMaker; +#require ExtUtils::Liblist; + +use vars qw(@ISA @EXPORT $VERSION + @Extensions $Verbose $lib_ext + $opt_o $opt_s + ); +use strict; + +$VERSION = sprintf("%d.%02d", q$Revision: 1.2505 $ =~ /(\d+)\.(\d+)/); + +@ISA = qw(Exporter); +@EXPORT = qw(&xsinit &ldopts + &ccopts &ccflags &ccdlflags &perl_inc + &xsi_header &xsi_protos &xsi_body); + +#let's have Miniperl borrow from us instead +#require ExtUtils::Miniperl; +#*canon = \&ExtUtils::Miniperl::canon; + +$Verbose = 0; +$lib_ext = $Config{lib_ext} || '.a'; + +sub is_cmd { $0 eq '-e' } + +sub my_return { + my $val = shift; + if(is_cmd) { + print $val; + } + else { + return $val; + } +} + +sub xsinit { + my($file, $std, $mods) = @_; + my($fh,@mods,%seen); + $file ||= "perlxsi.c"; + + if (@_) { + @mods = @$mods if $mods; + } + else { + getopts('o:s:'); + $file = $opt_o if defined $opt_o; + $std = $opt_s if defined $opt_s; + @mods = @ARGV; + } + $std = 1 unless scalar @mods; + + if ($file eq "STDOUT") { + $fh = \*STDOUT; + } + else { + $fh = new FileHandle "> $file"; + } + + push(@mods, static_ext()) if defined $std; + @mods = grep(!$seen{$_}++, @mods); + + print $fh &xsi_header(); + print $fh "EXTERN_C void xs_init _((void));\n\n"; + print $fh &xsi_protos(@mods); + + print $fh "\nEXTERN_C void\nxs_init()\n{\n"; + print $fh &xsi_body(@mods); + print $fh "}\n"; + +} + +sub xsi_header { + return <<EOF; +#ifdef __cplusplus +extern "C" { +#endif + +#include <EXTERN.h> +#include <perl.h> + +#ifdef __cplusplus +} +# ifndef EXTERN_C +# define EXTERN_C extern "C" +# endif +#else +# ifndef EXTERN_C +# define EXTERN_C extern +# endif +#endif + +EOF +} + +sub xsi_protos { + my(@exts) = @_; + my(@retval,%seen); + + foreach $_ (@exts){ + my($pname) = canon('/', $_); + my($mname, $cname); + ($mname = $pname) =~ s!/!::!g; + ($cname = $pname) =~ s!/!__!g; + my($ccode) = "EXTERN_C void boot_${cname} _((CV* cv));\n"; + next if $seen{$ccode}++; + push(@retval, $ccode); + } + return join '', @retval; +} + +sub xsi_body { + my(@exts) = @_; + my($pname,@retval,%seen); + my($dl) = canon('/','DynaLoader'); + push(@retval, "\tchar *file = __FILE__;\n"); + push(@retval, "\tdXSUB_SYS;\n") if $] > 5.002; + push(@retval, "\n"); + + foreach $_ (@exts){ + my($pname) = canon('/', $_); + my($mname, $cname, $ccode); + ($mname = $pname) =~ s!/!::!g; + ($cname = $pname) =~ s!/!__!g; + if ($pname eq $dl){ + # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'! + # boot_DynaLoader is called directly in DynaLoader.pm + $ccode = "\t/* DynaLoader is a special case */\n\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n"; + push(@retval, $ccode) unless $seen{$ccode}++; + } else { + $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n"; + push(@retval, $ccode) unless $seen{$ccode}++; + } + } + return join '', @retval; +} + +sub static_ext { + unless (scalar @Extensions) { + @Extensions = sort split /\s+/, $Config{static_ext}; + unshift @Extensions, qw(DynaLoader); + } + @Extensions; +} + +sub ldopts { + require ExtUtils::MakeMaker; + require ExtUtils::Liblist; + my($std,$mods,$link_args,$path) = @_; + my(@mods,@link_args,@argv); + my($dllib,$config_libs,@potential_libs,@path); + local($") = ' ' unless $" eq ' '; + my $MM = bless {} => 'MY'; + if (scalar @_) { + @link_args = @$link_args if $link_args; + @mods = @$mods if $mods; + } + else { + @argv = @ARGV; + #hmm + while($_ = shift @argv) { + /^-std$/ && do { $std = 1; next; }; + /^--$/ && do { @link_args = @argv; last; }; + /^-I(.*)/ && do { $path = $1 || shift @argv; next; }; + push(@mods, $_); + } + } + $std = 1 unless scalar @link_args; + @path = $path ? split(/:/, $path) : @INC; + + push(@potential_libs, @link_args) if scalar @link_args; + push(@potential_libs, $Config{libs}) if defined $std; + + push(@mods, static_ext()) if $std; + + my($mod,@ns,$root,$sub,$extra,$archive,@archives); + print STDERR "Searching (@path) for archives\n" if $Verbose; + foreach $mod (@mods) { + @ns = split('::', $mod); + $sub = $ns[-1]; + $root = $MM->catdir(@ns); + + print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose; + foreach (@path) { + next unless -e ($archive = $MM->catdir($_,"auto",$root,"$sub$lib_ext")); + push @archives, $archive; + if(-e ($extra = $MM->catdir($_,"auto",$root,"extralibs.ld"))) { + local(*FH); + if(open(FH, $extra)) { + my($libs) = <FH>; chomp $libs; + push @potential_libs, split /\s+/, $libs; + } + else { + warn "Couldn't open '$extra'"; + } + } + last; + } + } + #print STDERR "\@potential_libs = @potential_libs\n"; + + my $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] || "-lperl"; + + my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) = + $MM->ext(join ' ', + $MM->catdir("-L$Config{archlibexp}", "CORE"), " $libperl", + @potential_libs); + + my $ld_or_bs = $bsloadlibs || $ldloadlibs; + print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose; + my $linkage = "$Config{ccdlflags} $Config{ldflags} @archives $ld_or_bs"; + print STDERR "ldopts: '$linkage'\n" if $Verbose; + + return $linkage if scalar @_; + my_return("$linkage\n"); +} + +sub ccflags { + my_return(" $Config{ccflags} "); +} + +sub ccdlflags { + my_return(" $Config{ccdlflags} "); +} + +sub perl_inc { + my_return(" -I$Config{archlibexp}/CORE "); +} + +sub ccopts { + ccflags . perl_inc; +} + +sub canon { + my($as, @ext) = @_; + foreach(@ext) { + # might be X::Y or lib/auto/X/Y/Y.a + next if s!::!/!g; + s:^(lib|ext)/(auto/)?::; + s:/\w+\.\w+$::; + } + grep(s:/:$as:, @ext) if ($as ne '/'); + @ext; +} + +__END__ + +=head1 NAME + +ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications + +=head1 SYNOPSIS + + + perl -MExtUtils::Embed -e xsinit + perl -MExtUtils::Embed -e ldopts + +=head1 DESCRIPTION + +ExtUtils::Embed provides utility functions for embedding a Perl interpreter +and extensions in your C/C++ applications. +Typically, an application B<Makefile> will invoke ExtUtils::Embed +functions while building your application. + +=head1 @EXPORT + +ExtUtils::Embed exports the following functions: + +xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(), +ccdlflags(), xsi_header(), xsi_protos(), xsi_body() + +=head1 FUNCTIONS + +=over + +=item xsinit() + +Generate C/C++ code for the XS initializer function. + +When invoked as C<`perl -MExtUtils::Embed -e xsinit --`> +the following options are recognized: + +B<-o> E<lt>output filenameE<gt> (Defaults to B<perlxsi.c>) + +B<-o STDOUT> will print to STDOUT. + +B<-std> (Write code for extensions that are linked with the current Perl.) + +Any additional arguments are expected to be names of modules +to generate code for. + +When invoked with parameters the following are accepted and optional: + +C<xsinit($filename,$std,[@modules])> + +Where, + +B<$filename> is equivalent to the B<-o> option. + +B<$std> is boolean, equivalent to the B<-std> option. + +B<[@modules]> is an array ref, same as additional arguments mentioned above. + +=item Examples + + + perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket + + +This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function +to the C B<boot_Socket> function and writes it to a file named "xsinit.c". + +Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly. + + perl -MExtUtils::Embed -e xsinit + + +This will generate code for linking with B<DynaLoader> and +each static extension found in B<$Config{static_ext}>. +The code is written to the default file name B<perlxsi.c>. + + + perl -MExtUtils::Embed -e xsinit -- -o xsinit.c -std DBI DBD::Oracle + + +Here, code is written for all the currently linked extensions along with code +for B<DBI> and B<DBD::Oracle>. + +If you have a working B<DynaLoader> then there is rarely any need to statically link in any +other extensions. + +=item ldopts() + +Output arguments for linking the Perl library and extensions to your +application. + +When invoked as C<`perl -MExtUtils::Embed -e ldopts --`> +the following options are recognized: + +B<-std> + +Output arguments for linking the Perl library and any extensions linked +with the current Perl. + +B<-I> E<lt>path1:path2E<gt> + +Search path for ModuleName.a archives. +Default path is B<@INC>. +Library archives are expected to be found as +B</some/path/auto/ModuleName/ModuleName.a> +For example, when looking for B<Socket.a> relative to a search path, +we should find B<auto/Socket/Socket.a> + +When looking for B<DBD::Oracle> relative to a search path, +we should find B<auto/DBD/Oracle/Oracle.a> + +Keep in mind, you can always supply B</my/own/path/ModuleName.a> +as an additional linker argument. + +B<--> E<lt>list of linker argsE<gt> + +Additional linker arguments to be considered. + +Any additional arguments found before the B<--> token +are expected to be names of modules to generate code for. + +When invoked with parameters the following are accepted and optional: + +C<ldopts($std,[@modules],[@link_args],$path)> + +Where, + +B<$std> is boolean, equivalent to the B<-std> option. + +B<[@modules]> is equivalent to additional arguments found before the B<--> token. + +B<[@link_args]> is equivalent to arguments found after the B<--> token. + +B<$path> is equivalent to the B<-I> option. + +In addition, when ldopts is called with parameters, it will return the argument string +rather than print it to STDOUT. + +=item Examples + + + perl -MExtUtils::Embed -e ldopts + + +This will print arguments for linking with B<libperl.a>, B<DynaLoader> and +extensions found in B<$Config{static_ext}>. This includes libraries +found in B<$Config{libs}> and the first ModuleName.a library +for each extension that is found by searching B<@INC> or the path +specifed by the B<-I> option. +In addition, when ModuleName.a is found, additional linker arguments +are picked up from the B<extralibs.ld> file in the same directory. + + + perl -MExtUtils::Embed -e ldopts -- -std Socket + + +This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension. + + + perl -MExtUtils::Embed -e ldopts -- DynaLoader + + +This will print arguments for linking with just the B<DynaLoader> extension +and B<libperl.a>. + + + perl -MExtUtils::Embed -e ldopts -- -std Msql -- -L/usr/msql/lib -lmsql + + +Any arguments after the second '--' token are additional linker +arguments that will be examined for potential conflict. If there is no +conflict, the additional arguments will be part of the output. + + +=item perl_inc() + +For including perl header files this function simply prints: + + -I$Config{archlibexp}/CORE + +So, rather than having to say: + + perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"' + +Just say: + + perl -MExtUtils::Embed -e perl_inc + +=item ccflags(), ccdlflags() + +These functions simply print $Config{ccflags} and $Config{ccdlflags} + +=item ccopts() + +This function combines perl_inc(), ccflags() and ccdlflags() into one. + +=item xsi_header() + +This function simply returns a string defining the same B<EXTERN_C> macro as +B<perlmain.c> along with #including B<perl.h> and B<EXTERN.h>. + +=item xsi_protos(@modules) + +This function returns a string of B<boot_$ModuleName> prototypes for each @modules. + +=item xsi_body(@modules) + +This function returns a string of calls to B<newXS()> that glue the module B<bootstrap> +function to B<boot_ModuleName> for each @modules. + +B<xsinit()> uses the xsi_* functions to generate most of it's code. + +=back + +=head1 EXAMPLES + +For examples on how to use B<ExtUtils::Embed> for building C/C++ applications +with embedded perl, see the eg/ directory and L<perlembed>. + +=head1 SEE ALSO + +L<perlembed> + +=head1 AUTHOR + +Doug MacEachern E<lt>F<dougm@osf.org>E<gt> + +Based on ideas from Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and +B<minimod.pl> by Andreas Koenig E<lt>F<k@anna.in-berlin.de>E<gt> and Tim Bunce. + +=cut + diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm new file mode 100644 index 00000000000..3545f2c5a4e --- /dev/null +++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm @@ -0,0 +1,784 @@ +package ExtUtils::MM_Win32; + +=head1 NAME + +ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker + +=head1 SYNOPSIS + + use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed + +=head1 DESCRIPTION + +See ExtUtils::MM_Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over + +=cut + +use Config; +#use Cwd; +use File::Basename; +require Exporter; + +Exporter::import('ExtUtils::MakeMaker', + qw( $Verbose &neatvalue)); + +$ENV{EMXSHELL} = 'sh'; # to run `commands` +unshift @MM::ISA, 'ExtUtils::MM_Win32'; + +$BORLAND = 1 if $Config{'cc'} =~ /^bcc/i; +$DMAKE = 1 if $Config{'make'} =~ /^dmake/i; +$NMAKE = 1 if $Config{'make'} =~ /^nmake/i; + +sub dlsyms { + my($self,%attribs) = @_; + + my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; + my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; + my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {}; + my(@m); + (my $boot = $self->{NAME}) =~ s/:/_/g; + + if (not $self->{SKIPHASH}{'dynamic'}) { + push(@m," +$self->{BASEEXT}.def: Makefile.PL +", + q! $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Mksymlists \\ + -e "Mksymlists('NAME' => '!, $self->{NAME}, + q!', 'DLBASE' => '!,$self->{DLBASE}, + q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'IMPORTS' => !,neatvalue($imports), + q!, 'DL_VARS' => !, neatvalue($vars), q!);" +!); + } + join('',@m); +} + +sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; +} + +sub maybe_command { + my($self,$file) = @_; + return "$file.exe" if -e "$file.exe"; + return; +} + +sub file_name_is_absolute { + my($self,$file) = @_; + $file =~ m{^([a-z]:)?[\\/]}i ; +} + +sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + my($name, $dir); + if ($trace >= 2){ + print "Looking for perl $ver by these names: +@$names +in these dirs: +@$dirs +"; + } + foreach $dir (@$dirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined + foreach $name (@$names){ + my ($abs, $val); + if ($self->file_name_is_absolute($name)) { # /foo/bar + $abs = $name; + } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo + $abs = $self->catfile($dir, $name); + } else { # foo/bar + $abs = $self->canonpath($self->catfile($self->curdir, $name)); + } + print "Checking $abs\n" if ($trace >= 2); + next unless $self->maybe_command($abs); + print "Executing $abs\n" if ($trace >= 2); + $val = `$abs -e "require $ver;" 2>&1`; + if ($? == 0) { + print "Using PERL=$abs\n" if $trace; + return $abs; + } elsif ($trace >= 2) { + print "Result: `$val'\n"; + } + } + } + print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + +sub catdir { + my $self = shift; + my @args = @_; + for (@args) { + # append a slash to each argument unless it has one there + $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; + } + my $result = $self->canonpath(join('', @args)); + $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + my $self = shift @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + $dir =~ s/(\\\.)$//; + $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\"; + return $dir.$file; +} + +sub init_others +{ + my ($self) = @_; + &ExtUtils::MM_Unix::init_others; + $self->{'TOUCH'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e touch'; + $self->{'CHMOD'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e chmod'; + $self->{'CP'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp'; + $self->{'RM_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f'; + $self->{'RM_RF'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf'; + $self->{'MV'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mv'; + $self->{'NOOP'} = 'rem'; + $self->{'TEST_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f'; + $self->{'LD'} = $Config{'ld'} || 'link'; + $self->{'AR'} = $Config{'ar'} || 'lib'; + $self->{'LDLOADLIBS'} + ||= ( $BORLAND + ? 'import32.lib cw32mti.lib ' + : 'msvcrt.lib oldnames.lib kernel32.lib comdlg32.lib winspool.lib gdi32.lib ' + .'advapi32.lib user32.lib shell32.lib netapi32.lib ole32.lib ' + .'oleaut32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib ' + ) . ' odbc32.lib odbccp32.lib'; + $self->{'DEV_NULL'} = '> NUL'; + # $self->{'NOECHO'} = ''; # till we have it working +} + + +=item constants (o) + +Initializes lots of constants and .SUFFIXES and .PHONY + +=cut + +sub constants { + my($self) = @_; + my(@m,$tmp); + + for $tmp (qw/ + + AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION + VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB + INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS + INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB + INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB + PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB + FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC + PERL_INC PERL FULLPERL + + / ) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + push @m, qq{ +VERSION_MACRO = VERSION +DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\" +XS_VERSION_MACRO = XS_VERSION +XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\" +}; + + push @m, qq{ +MAKEMAKER = $INC{'ExtUtils\MakeMaker.pm'} +MM_VERSION = $ExtUtils::MakeMaker::VERSION +}; + + push @m, q{ +# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) +# ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!! +# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) +# DLBASE = Basename part of dynamic library. May be just equal BASEEXT. +}; + + for $tmp (qw/ + FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT + LDFROM LINKTYPE + / ) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + push @m, " +# Handy lists of source code files: +XS_FILES= ".join(" \\\n\t", sort keys %{$self->{XS}})." +C_FILES = ".join(" \\\n\t", @{$self->{C}})." +O_FILES = ".join(" \\\n\t", @{$self->{O_FILES}})." +H_FILES = ".join(" \\\n\t", @{$self->{H}})." +MAN1PODS = ".join(" \\\n\t", sort keys %{$self->{MAN1PODS}})." +MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})." +"; + + for $tmp (qw/ + INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT + /) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + + push @m, qq{ +.USESHELL : +} if $DMAKE; + + push @m, q{ +.NO_CONFIG_REC: Makefile +} if $ENV{CLEARCASE_ROOT}; + + # why not q{} ? -- emacs + push @m, qq{ +# work around a famous dec-osf make(1) feature(?): +makemakerdflt: all + +.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT) + +# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that +# some make implementations will delete the Makefile when we rebuild it. Because +# we call false(1) when we rebuild it. So make(1) is not completely wrong when it +# does so. Our milage may vary. +# .PRECIOUS: Makefile # seems to be not necessary anymore + +.PHONY: all config static dynamic test linkext manifest + +# Where is the Config information that we are using/depend on +CONFIGDEP = \$(PERL_ARCHLIB)\\Config.pm \$(PERL_INC)\\config.h +}; + + my @parentdir = split(/::/, $self->{PARENT_NAME}); + push @m, q{ +# Where to put things: +INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{ +INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{ + +INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ +INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ +}; + + if ($self->has_link_code()) { + push @m, ' +INST_STATIC = $(INST_ARCHAUTODIR)\$(BASEEXT)$(LIB_EXT) +INST_DYNAMIC = $(INST_ARCHAUTODIR)\$(DLBASE).$(DLEXT) +INST_BOOT = $(INST_ARCHAUTODIR)\$(BASEEXT).bs +'; + } else { + push @m, ' +INST_STATIC = +INST_DYNAMIC = +INST_BOOT = +'; + } + + $tmp = $self->export_list; + push @m, " +EXPORT_LIST = $tmp +"; + $tmp = $self->perl_archive; + push @m, " +PERL_ARCHIVE = $tmp +"; + +# push @m, q{ +#INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{ +# +#PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ +#}; + + push @m, q{ +TO_INST_PM = }.join(" \\\n\t", sort keys %{$self->{PM}}).q{ + +PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ +}; + + join('',@m); +} + + +sub path { + local $^W = 1; + my($self) = @_; + my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; + my @path = split(';',$path); + foreach(@path) { $_ = '.' if $_ eq '' } + @path; +} + +=item static_lib (o) + +Defines how to produce the *.a (or equivalent) files. + +=cut + +sub static_lib { + my($self) = @_; +# Come to think of it, if there are subdirs with linkcode, we still have no INST_STATIC +# return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my(@m); + push(@m, <<'END'); +$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)\.exists + $(RM_RF) $@ +END + # If this extension has it's own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB}; + + push @m, +q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")' : '-out:$@ $(OBJECT)').q{ + }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld + $(CHMOD) 755 $@ +}; + +# Old mechanism - still available: + + push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs}."\n\n" + if $self->{PERL_SRC}; + + push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); + join('', "\n",@m); +} + +=item dynamic_bs (o) + +Defines targets for bootstrap files. + +=cut + +sub dynamic_bs { + my($self, %attribs) = @_; + return ' +BOOTSTRAP = +' unless $self->has_link_code(); + + return ' +BOOTSTRAP = '."$self->{BASEEXT}.bs".' + +# As Mkbootstrap might not write a file (if none is required) +# we use touch to prevent make continually trying to remake it. +# The DynaLoader only reads a non-empty file. +$(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)\.exists + '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))" + '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ + -MExtUtils::Mkbootstrap \ + -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" + '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP) + $(CHMOD) 644 $@ + +$(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists + '."$self->{NOECHO}$self->{RM_RF}".' $(INST_BOOT) + -'.$self->{CP}.' $(BOOTSTRAP) $(INST_BOOT) + $(CHMOD) 644 $@ +'; +} + +=item dynamic_lib (o) + +Defines how to produce the *.so (or equivalent) files. + +=cut + +sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + + return '' unless $self->has_link_code; + + my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); + my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; + my($ldfrom) = '$(LDFROM)'; + my(@m); + push(@m,' +# This section creates the dynamically loadable $(INST_DYNAMIC) +# from $(OBJECT) and possibly $(MYEXTLIB). +OTHERLDFLAGS = '.$otherldflags.' +INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' + +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) +'); + + push(@m, $BORLAND ? +q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,),$(RESFILES)} : +q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)} + ); + push @m, ' + $(CHMOD) 755 $@ +'; + + push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); + join('',@m); +} + +sub perl_archive +{ + return '$(PERL_INC)\perl$(LIB_EXT)'; +} + +sub export_list +{ + my ($self) = @_; + return "$self->{BASEEXT}.def"; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=cut + +sub canonpath { + my($self,$path) = @_; + $path =~ s/^([a-z]:)/\u$1/; + $path =~ s|/|\\|g; + $path =~ s|(.)\\+|$1\\|g ; # xx////xx -> xx/xx + $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx + $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx + $path =~ s|\\$|| + unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx + $path .= '.' if $path =~ m#\\$#; + $path; +} + +=item perl_script + +Takes one argument, a file name, and returns the file name, if the +argument is likely to be a perl script. On MM_Unix this is true for +any ordinary, readable file. + +=cut + +sub perl_script { + my($self,$file) = @_; + return "$file.pl" if -r "$file.pl" && -f _; + return; +} + +=item pm_to_blib + +Defines target that copies all files in the hash PM to their +destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> + +=cut + +sub pm_to_blib { + my $self = shift; + my($autodir) = $self->catdir('$(INST_LIB)','auto'); + return q{ +pm_to_blib: $(TO_INST_PM) + }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ + "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ + -e "pm_to_blib(qw[ }. + ($NMAKE ? '<<pmfiles.dat' + : '$(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n)'). + q{ ],'}.$autodir.q{')" + }. ($NMAKE ? q{ +$(PM_TO_BLIB) +<< + } : '') . $self->{NOECHO}.q{$(TOUCH) $@ +}; +} + +=item test_via_harness (o) + +Helper method to write the test targets + +=cut + +sub test_via_harness { + my($self, $perl, $tests) = @_; + "\t$perl".q! -Mblib -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e "use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;" !."$tests\n"; +} + + +=item tool_autosplit (override) + +Use Win32 quoting on command line. + +=cut + +sub tool_autosplit{ + my($self, %attribs) = @_; + my($asl) = ""; + $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN}; + q{ +# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto +AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MAutoSplit }.$asl.q{ -e "autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1);" +}; +} + +=item tools_other (o) + +Win32 overrides. + +Defines SHELL, LD, TOUCH, CP, MV, RM_F, RM_RF, CHMOD, UMASK_NULL in +the Makefile. Also defines the perl programs MKPATH, +WARN_IF_OLD_PACKLIST, MOD_INSTALL. DOC_INSTALL, and UNINSTALL. + +=cut + +sub tools_other { + my($self) = shift; + my @m; + my $bin_sh = $Config{sh} || 'cmd /c'; + push @m, qq{ +SHELL = $bin_sh +} unless $DMAKE; # dmake determines its own shell + + for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) { + push @m, "$_ = $self->{$_}\n"; + } + + push @m, q{ +# The following is a portable way to say mkdir -p +# To see which directories are created, change the if 0 to if 1 +MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath + +# This helps us to minimize the effect of the .exists files A yet +# better solution would be to have a stable file in the perl +# distribution with a timestamp of zero. But this solution doesn't +# need any changes to the core distribution and works with older perls +EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime +}; + + + return join "", @m if $self->{PARENT}; + + push @m, q{ +# Here we warn users that an old packlist file was found somewhere, +# and that they should call some uninstall routine +WARN_IF_OLD_PACKLIST = $(PERL) -lwe "exit unless -f $$ARGV[0];" \\ +-e "print 'WARNING: I have found an old package in';" \\ +-e "print ' ', $$ARGV[0], '.';" \\ +-e "print 'Please make sure the two installations are not conflicting';" + +UNINST=0 +VERBINST=1 + +MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ +-e "install({ @ARGV },'$(VERBINST)',0,'$(UNINST)');" + +DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \ +-e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', shift, '>';" \ +-e "print '=over 4';" \ +-e "while (defined($$key = shift) and defined($$val = shift)) { print '=item *';print 'C<', \"$$key: $$val\", '>'; }" \ +-e "print '=back';" + +UNINSTALL = $(PERL) -MExtUtils::Install \ +-e "uninstall($$ARGV[0],1,1); print \"\nUninstall is deprecated. Please check the";" \ +-e "print \" packlist above carefully.\n There may be errors. Remove the\";" \ +-e "print \" appropriate files manually.\n Sorry for the inconveniences.\n\"" +}; + + return join "", @m; +} + +=item xs_o (o) + +Defines suffix rules to go from XS to object files directly. This is +only intended for broken make implementations. + +=cut + +sub xs_o { # many makes are too dumb to use xs_c then c_o + my($self) = shift; + return '' +} + +=item top_targets (o) + +Defines the targets all, subdirs, config, and O_FILES + +=cut + +sub top_targets { +# --- Target Sections --- + + my($self) = shift; + my(@m); + push @m, ' +#all :: config $(INST_PM) subdirs linkext manifypods +'; + + push @m, ' +all :: pure_all manifypods + '.$self->{NOECHO}.'$(NOOP) +' + unless $self->{SKIPHASH}{'all'}; + + push @m, ' +pure_all :: config pm_to_blib subdirs linkext + '.$self->{NOECHO}.'$(NOOP) + +subdirs :: $(MYEXTLIB) + '.$self->{NOECHO}.'$(NOOP) + +config :: '.$self->{MAKEFILE}.' $(INST_LIBDIR)\.exists + '.$self->{NOECHO}.'$(NOOP) + +config :: $(INST_ARCHAUTODIR)\.exists + '.$self->{NOECHO}.'$(NOOP) + +config :: $(INST_AUTODIR)\.exists + '.$self->{NOECHO}.'$(NOOP) +'; + + push @m, qq{ +config :: Version_check + $self->{NOECHO}\$(NOOP) + +} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; + + push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); + + if (%{$self->{MAN1PODS}}) { + push @m, qq[ +config :: \$(INST_MAN1DIR)\\.exists + $self->{NOECHO}\$(NOOP) + +]; + push @m, $self->dir_target(qw[$(INST_MAN1DIR)]); + } + if (%{$self->{MAN3PODS}}) { + push @m, qq[ +config :: \$(INST_MAN3DIR)\\.exists + $self->{NOECHO}\$(NOOP) + +]; + push @m, $self->dir_target(qw[$(INST_MAN3DIR)]); + } + + push @m, ' +$(O_FILES): $(H_FILES) +' if @{$self->{O_FILES} || []} && @{$self->{H} || []}; + + push @m, q{ +help: + perldoc ExtUtils::MakeMaker +}; + + push @m, q{ +Version_check: + }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ + -MExtUtils::MakeMaker=Version_check \ + -e "Version_check('$(MM_VERSION)')" +}; + + join('',@m); +} + +=item manifypods (o) + +We don't want manpage process. XXX add pod2html support later. + +=cut + +sub manifypods { + return "\nmanifypods :\n\t$self->{NOECHO}\$(NOOP)\n"; +} + +=item dist_ci (o) + +Same as MM_Unix version (changes command-line quoting). + +=cut + +sub dist_ci { + my($self) = shift; + my @m; + push @m, q{ +ci : + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\ + -e "@all = keys %{ maniread() };" \\ + -e "print(\"Executing $(CI) @all\n\"); system(\"$(CI) @all\");" \\ + -e "print(\"Executing $(RCS_LABEL) ...\n\"); system(\"$(RCS_LABEL) @all\");" +}; + join "", @m; +} + +=item dist_core (o) + +Same as MM_Unix version (changes command-line quoting). + +=cut + +sub dist_core { + my($self) = shift; + my @m; + push @m, q{ +dist : $(DIST_DEFAULT) + }.$self->{NOECHO}.q{$(PERL) -le "print \"Warning: Makefile possibly out of date with $$vf\" if " \ + -e "-e ($$vf=\"$(VERSION_FROM)\") and -M $$vf < -M \"}.$self->{MAKEFILE}.q{\";" + +tardist : $(DISTVNAME).tar$(SUFFIX) + +zipdist : $(DISTVNAME).zip + +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) + +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(POSTOP) + +uutardist : $(DISTVNAME).tar$(SUFFIX) + uuencode $(DISTVNAME).tar$(SUFFIX) \\ + $(DISTVNAME).tar$(SUFFIX) > \\ + $(DISTVNAME).tar$(SUFFIX)_uu + +shdist : distdir + $(PREOP) + $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar + $(RM_RF) $(DISTVNAME) + $(POSTOP) +}; + join "", @m; +} + +=item pasthru (o) + +Defines the string that is passed to recursive make calls in +subdirectories. + +=cut + +sub pasthru { + my($self) = shift; + return "PASTHRU = " . ($NMAKE ? "-nologo" : ""); +} + + + +1; +__END__ + +=back + +=cut + diff --git a/gnu/usr.bin/perl/lib/File/Compare.pm b/gnu/usr.bin/perl/lib/File/Compare.pm new file mode 100644 index 00000000000..2f9c45c4c60 --- /dev/null +++ b/gnu/usr.bin/perl/lib/File/Compare.pm @@ -0,0 +1,143 @@ +package File::Compare; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); + +require Exporter; +use Carp; + +$VERSION = '1.1001'; +@ISA = qw(Exporter); +@EXPORT = qw(compare); +@EXPORT_OK = qw(cmp); + +$Too_Big = 1024 * 1024 * 2; + +sub VERSION { + # Version of File::Compare + return $File::Compare::VERSION; +} + +sub compare { + croak("Usage: compare( file1, file2 [, buffersize]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + my $closefrom=0; + my $closeto=0; + my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf); + local(*FROM, *TO); + local($\) = ''; + + croak("from undefined") unless (defined $from); + croak("to undefined") unless (defined $to); + + if (ref($from) && + (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { + *FROM = *$from; + } elsif (ref(\$from) eq 'GLOB') { + *FROM = $from; + } else { + open(FROM,"<$from") or goto fail_open1; + binmode FROM; + $closefrom = 1; + $fromsize = -s FROM; + } + + if (ref($to) && + (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { + *TO = *$to; + } elsif (ref(\$to) eq 'GLOB') { + *TO = $to; + } else { + open(TO,"<$to") or goto fail_open2; + binmode TO; + $closeto = 1; + } + + if ($closefrom && $closeto) { + # If both are opened files we know they differ if their size differ + goto fail_inner if $fromsize != -s TO; + } + + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for compare: $size\n") unless ($size > 0); + } else { + $size = $fromsize; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + $fbuf = ''; + $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) { + goto fail_inner; + } + } + goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0); + + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 0; + + # All of these contortions try to preserve error messages... + fail_inner: + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 1; + + fail_open2: + if ($closefrom) { + $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return -1; +} + +*cmp = \&compare; + +1; + +__END__ + +=head1 NAME + +File::Compare - Compare files or filehandles + +=head1 SYNOPSIS + + use File::Compare; + + if (compare("file1","file2") == 0) { + print "They're equal\n"; + } + +=head1 DESCRIPTION + +The File::Compare::compare function compares the contents of two +sources, each of which can be a file or a file handle. It is exported +from File::Compare by default. + +File::Compare::cmp is a synonym for File::Compare::compare. It is +exported from File::Compare only by request. + +=head1 RETURN + +File::Compare::compare return 0 if the files are equal, 1 if the +files are unequal, or -1 if an error was encountered. + +=head1 AUTHOR + +File::Compare was written by Nick Ing-Simmons. +Its original documentation was written by Chip Salzenberg. + +=cut + diff --git a/gnu/usr.bin/perl/lib/File/DosGlob.pm b/gnu/usr.bin/perl/lib/File/DosGlob.pm new file mode 100644 index 00000000000..4597c715640 --- /dev/null +++ b/gnu/usr.bin/perl/lib/File/DosGlob.pm @@ -0,0 +1,250 @@ +#!perl -w + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +unless (caller) { + $| = 1; + while (@ARGV) { + # + # We have to do this one by one for compatibility reasons. + # If an arg doesn't match anything, we are supposed to return + # the original arg. I know, it stinks, eh? + # + my $arg = shift; + my @m = doglob(1,$arg); + print (@m ? join("\0", sort @m) : $arg); + print "\0" if @ARGV; + } +} + +sub doglob { + my $cond = shift; + my @retval = (); + #print "doglob: ", join('|', @_), "\n"; + OUTER: + for my $arg (@_) { + local $_ = $arg; + my @matched = (); + my @globdirs = (); + my $head = '.'; + my $sepchr = '/'; + next OUTER unless defined $_ and $_ ne ''; + # if arg is within quotes strip em and do no globbing + if (/^"(.*)"$/) { + $_ = $1; + if ($cond eq 'd') { push(@retval, $_) if -d $_ } + else { push(@retval, $_) if -e $_ } + next OUTER; + } + if (m|^(.*)([\\/])([^\\/]*)$|) { + my $tail; + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $_), next OUTER if $tail eq ''; + if ($head =~ /[*?]/) { + @globdirs = doglob('d', $head); + push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), + next OUTER if @globdirs; + } + $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/; + $_ = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + unless (/[*?]/) { + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + $head .= $_; + if ($cond eq 'd') { push(@retval,$head) if -d $head } + else { push(@retval,$head) if -e $head } + next OUTER; + } + opendir(D, $head) or next OUTER; + my @leaves = readdir D; + closedir D; + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + + # escape regex metachars but not glob chars + s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex + s/\*/.*/g; + s/\?/.?/g; + + #print "regex: '$_', head: '$head'\n"; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }'; + warn($@), next OUTER if $@; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$head$e"; + push(@matched, "$head$e"), next INNER if &$matchsub($e); + # + # [DOS compatibility special case] + # Failed, add a trailing dot and try again, but only + # if name does not have a dot in it *and* pattern + # has a dot *and* name is shorter than 9 chars. + # + if (index($e,'.') == -1 and length($e) < 9 + and index($_,'\\.') != -1) { + push(@matched, "$head$e"), next INNER if &$matchsub("$e."); + } + } + push @retval, @matched if @matched; + } + return @retval; +} + +# +# this can be used to override CORE::glob in a specific +# package by saying C<use File::DosGlob 'glob';> in that +# namespace. +# + +# context (keyed by second cxix arg provided by core) +my %iter; +my %entries; + +sub glob { + my $pat = shift; + my $cxix = shift; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + $entries{$cxix} = [doglob(1,$pat)]; + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} + +sub import { + my $pkg = shift; + my $callpkg = caller(0); + my $sym = shift; + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} + if defined($sym) and $sym eq 'glob'; +} + +1; + +__END__ + +=head1 NAME + +File::DosGlob - DOS like globbing and then some + +perlglob.bat - a more capable perlglob.exe replacement + +=head1 SYNOPSIS + + require 5.004; + + # override CORE::glob in current package + use File::DosGlob 'glob'; + + @perlfiles = glob "..\\pe?l/*.p?"; + print <..\\pe?l/*.p?>; + + # from the command line (overrides only in main::) + > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" + + > perlglob ../pe*/*p? + +=head1 DESCRIPTION + +A module that implements DOS-like globbing with a few enhancements. +This file is also a portable replacement for perlglob.exe. It +is largely compatible with perlglob.exe (the M$ setargv.obj +version) in all but one respect--it understands wildcards in +directory components. + +For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in +that it will find something like '..\lib\File/DosGlob.pm' alright). +Note that all path components are case-insensitive, and that +backslashes and forward slashes are both accepted, and preserved. +You may have to double the backslashes if you are putting them in +literally, due to double-quotish parsing of the pattern by perl. + +When invoked as a program, it will print null-separated filenames +to standard output. + +While one may replace perlglob.exe with this, usage by overriding +CORE::glob via importation should be much more efficient, because +it avoids launching a separate process, and is therefore strongly +recommended. Note that it is currently possible to override +builtins like glob() only on a per-package basis, not "globally". +Thus, every namespace that wants to override glob() must explicitly +request the override. See L<perlsub>. + +Extending it to csh patterns is left as an exercise to the reader. + +=head1 EXPORTS (by request only) + +glob() + +=head1 BUGS + +Should probably be built into the core, and needs to stop +pandering to DOS habits. Needs a dose of optimizium too. + +=head1 AUTHOR + +Gurusamy Sarathy <gsar@umich.edu> + +=head1 HISTORY + +=over 4 + +=item * + +Scalar context, independent iterator context fixes (GSAR 15-SEP-97) + +=item * + +A few dir-vs-file optimizations result in glob importation being +10 times faster than using perlglob.exe, and using perlglob.bat is +only twice as slow as perlglob.exe (GSAR 28-MAY-97) + +=item * + +Several cleanups prompted by lack of compatible perlglob.exe +under Borland (GSAR 27-MAY-97) + +=item * + +Initial version (GSAR 20-FEB-97) + +=back + +=head1 SEE ALSO + +perl + +=cut + diff --git a/gnu/usr.bin/perl/lib/File/stat.pm b/gnu/usr.bin/perl/lib/File/stat.pm new file mode 100644 index 00000000000..f5d17f7da44 --- /dev/null +++ b/gnu/usr.bin/perl/lib/File/stat.pm @@ -0,0 +1,113 @@ +package File::stat; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(stat lstat); + @EXPORT_OK = qw( $st_dev $st_ino $st_mode + $st_nlink $st_uid $st_gid + $st_rdev $st_size + $st_atime $st_mtime $st_ctime + $st_blksize $st_blocks + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'File::stat' => [ + map { $_ => '$' } qw{ + dev ino mode nlink uid gid rdev size + atime mtime ctime blksize blocks + } +]; + +sub populate (@) { + return unless @_; + my $stob = new(); + @$stob = ( + $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev, + $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) + = @_; + return $stob; +} + +sub lstat ($) { populate(CORE::lstat(shift)) } + +sub stat ($) { + my $arg = shift; + my $st = populate(CORE::stat $arg); + return $st if $st; + no strict 'refs'; + require Symbol; + return populate(CORE::stat \*{Symbol::qualify($arg)}); +} + +1; +__END__ + +=head1 NAME + +File::stat - by-name interface to Perl's built-in stat() functions + +=head1 SYNOPSIS + + use File::stat; + $st = stat($file) or die "No $file: $!"; + if ( ($st->mode & 0111) && $st->nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + + use File::stat qw(:FIELDS); + stat($file) or die "No $file: $!"; + if ( ($st_mode & 0111) && $st_nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + +=head1 DESCRIPTION + +This module's default exports override the core stat() +and lstat() functions, replacing them with versions that return +"File::stat" objects. This object has methods that +return the similarly named structure field name from the +stat(2) function; namely, +dev, +ino, +mode, +nlink, +uid, +gid, +rdev, +size, +atime, +mtime, +ctime, +blksize, +and +blocks. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your stat() and lstat() functions.) Access these fields as +variables named with a preceding C<st_> in front their method names. +Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import +the fields. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/FileHandle.pm b/gnu/usr.bin/perl/lib/FileHandle.pm new file mode 100644 index 00000000000..455fc63917d --- /dev/null +++ b/gnu/usr.bin/perl/lib/FileHandle.pm @@ -0,0 +1,258 @@ +package FileHandle; + +use 5.003_11; +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); + +$VERSION = "2.00"; + +require IO::File; +@ISA = qw(IO::File); + +@EXPORT = qw(_IOFBF _IOLBF _IONBF); + +@EXPORT_OK = qw( + pipe + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + + print + printf + getline + getlines +); + +# +# Everything we're willing to export, we must first import. +# +import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK; + +# +# Some people call "FileHandle::function", so all the functions +# that were in the old FileHandle class must be imported, too. +# +{ + no strict 'refs'; + + my %import = ( + 'IO::Handle' => + [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets + eof flush error clearerr setbuf setvbuf _open_mode_string)], + 'IO::Seekable' => + [qw(seek tell getpos setpos)], + 'IO::File' => + [qw(new new_tmpfile open)] + ); + for my $pkg (keys %import) { + for my $func (@{$import{$pkg}}) { + my $c = *{"${pkg}::$func"}{CODE} + or die "${pkg}::$func missing"; + *$func = $c; + } + } +} + +# +# Specialized importer for Fcntl magic. +# +sub import { + my $pkg = shift; + my $callpkg = caller; + require Exporter; + Exporter::export($pkg, $callpkg, @_); + + # + # If the Fcntl extension is available, + # export its constants. + # + eval { + require Fcntl; + Exporter::export('Fcntl', $callpkg); + }; +} + +################################################ +# This is the only exported function we define; +# the rest come from other classes. +# + +sub pipe { + my $r = new IO::Handle; + my $w = new IO::Handle; + CORE::pipe($r, $w) or return undef; + ($r, $w); +} + +# Rebless standard file handles +bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; +bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; +bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; + +1; + +__END__ + +=head1 NAME + +FileHandle - supply object methods for filehandles + +=head1 SYNOPSIS + + use FileHandle; + + $fh = new FileHandle; + if ($fh->open "< file") { + print <$fh>; + $fh->close; + } + + $fh = new FileHandle "> FOO"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new FileHandle "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new FileHandle "file", O_WRONLY|O_APPEND; + if (defined $fh) { + print $fh "corge\n"; + undef $fh; # automatically closes the file + } + + $pos = $fh->getpos; + $fh->setpos($pos); + + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + ($readfh, $writefh) = FileHandle::pipe; + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +NOTE: This class is now a front-end to the IO::* classes. + +C<FileHandle::new> creates a C<FileHandle>, which is a reference to a +newly created symbol (see the C<Symbol> package). If it receives any +parameters, they are passed to C<FileHandle::open>; if the open fails, +the C<FileHandle> object is destroyed. Otherwise, it is returned to +the caller. + +C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does. +It requires two parameters, which are passed to C<FileHandle::fdopen>; +if the fdopen fails, the C<FileHandle> object is destroyed. +Otherwise, it is returned to the caller. + +C<FileHandle::open> accepts one parameter or two. With one parameter, +it is just a front end for the built-in C<open> function. With two +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode, optionally followed by a file permission value. + +If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator. + +If C<FileHandle::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +For convenience, C<FileHandle::import> tries to import the O_XXX +constants from the Fcntl module. If dynamic loading is not available, +this may fail, but the rest of FileHandle will still work. + +C<FileHandle::fdopen> is like C<open> except that its first parameter +is not a filename but rather a file handle name, a FileHandle object, +or a file descriptor number. + +If the C functions fgetpos() and fsetpos() are available, then +C<FileHandle::getpos> returns an opaque value that represents the +current position of the FileHandle, and C<FileHandle::setpos> uses +that value to return to a previously visited position. + +If the C function setvbuf() is available, then C<FileHandle::setvbuf> +sets the buffering policy for the FileHandle. The calling sequence +for the Perl function is the same as its C counterpart, including the +macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer +parameter specifies a scalar variable to use as a buffer. WARNING: A +variable used as a buffer by C<FileHandle::setvbuf> must not be +modified in any way until the FileHandle is closed or until +C<FileHandle::setvbuf> is called again, or memory corruption may +result! + +See L<perlfunc> for complete descriptions of each of the following +supported C<FileHandle> methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + gets + eof + clearerr + seek + tell + +See L<perlvar> for complete descriptions of each of the following +supported C<FileHandle> methods: + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + +Furthermore, for doing normal I/O you might need these: + +=over + +=item $fh->print + +See L<perlfunc/print>. + +=item $fh->printf + +See L<perlfunc/printf>. + +=item $fh->getline + +This works like <$fh> described in L<perlop/"I/O Operators"> +except that it's more readable and can be safely called in an +array context but still returns just one line. + +=item $fh->getlines + +This works like <$fh> when called in an array context to +read all the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=back + +=head1 SEE ALSO + +The B<IO> extension, +L<perlfunc>, +L<perlop/"I/O Operators">. + +=cut diff --git a/gnu/usr.bin/perl/lib/FindBin.pm b/gnu/usr.bin/perl/lib/FindBin.pm new file mode 100644 index 00000000000..918775cda7f --- /dev/null +++ b/gnu/usr.bin/perl/lib/FindBin.pm @@ -0,0 +1,188 @@ +# FindBin.pm +# +# Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. + +=head1 NAME + +FindBin - Locate directory of original perl script + +=head1 SYNOPSIS + + use FindBin; + use lib "$FindBin::Bin/../lib"; + + or + + use FindBin qw($Bin); + use lib "$Bin/../lib"; + +=head1 DESCRIPTION + +Locates the full path to the script bin directory to allow the use +of paths relative to the bin directory. + +This allows a user to setup a directory tree for some software with +directories E<lt>rootE<gt>/bin and E<lt>rootE<gt>/lib and then the above example will allow +the use of modules in the lib directory without knowing where the software +tree is installed. + +If perl is invoked using the B<-e> option or the perl script is read from +C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current +directory. + +=head1 EXPORTABLE VARIABLES + + $Bin - path to bin directory from where script was invoked + $Script - basename of script from which perl was invoked + $RealBin - $Bin with all links resolved + $RealScript - $Script with all links resolved + +=head1 KNOWN BUGS + +if perl is invoked as + + perl filename + +and I<filename> does not have executable rights and a program called I<filename> +exists in the users C<$ENV{PATH}> which satisfies both B<-x> and B<-T> then FindBin +assumes that it was invoked via the C<$ENV{PATH}>. + +Workaround is to invoke perl as + + perl ./filename + +=head1 AUTHORS + +Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> +Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 REVISION + +$Revision: 1.4 $ + +=cut + +package FindBin; +use Carp; +require 5.000; +require Exporter; +use Cwd qw(getcwd abs_path); +use Config; +use File::Basename; + +@EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir); +%EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); +@ISA = qw(Exporter); + +$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); + +sub is_abs_path +{ + local $_ = shift if (@_); + if ($^O eq 'MSWin32') + { + return m#^[a-z]:[\\/]#i; + } + elsif ($^O eq 'VMS') + { + # If it's a logical name, expand it. + $_ = $ENV{$_} while /^[\w\$\-]+$/ and $ENV{$_}; + return m!^/! or m![<\[][^.\-\]>]! or /:[^<\[]/; + } + else + { + return m#^/#; + } +} + +BEGIN +{ + *Dir = \$Bin; + *RealDir = \$RealBin; + + if($0 eq '-e' || $0 eq '-') + { + # perl invoked with -e or script is on C<STDIN> + + $Script = $RealScript = $0; + $Bin = $RealBin = getcwd(); + } + else + { + my $script = $0; + + if ($^O eq 'VMS') + { + ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/; + ($RealBin,$RealScript) = ($Bin,$Script); + } + else + { + my $IsWin32 = $^O eq 'MSWin32'; + unless(($script =~ m#/# || ($IsWin32 && $script =~ m#\\#)) + && -f $script) + { + my $dir; + my $pathvar = ($IsWin32) ? 'Path' : 'PATH'; + + foreach $dir (split(/$Config{'path_sep'}/,$ENV{$pathvar})) + { + if(-r "$dir/$script" && (!$IsWin32 || -x _)) + { + $script = "$dir/$script"; + + if (-f $0) + { + # $script has been found via PATH but perl could have + # been invoked as 'perl file'. Do a dumb check to see + # if $script is a perl program, if not then $script = $0 + # + # well we actually only check that it is an ASCII file + # we know its executable so it is probably a script + # of some sort. + + $script = $0 unless(-T $script); + } + last; + } + } + } + + croak("Cannot find current script '$0'") unless(-f $script); + + # Ensure $script contains the complete path incase we C<chdir> + + $script = getcwd() . "/" . $script unless is_abs_path($script); + + ($Script,$Bin) = fileparse($script); + + # Resolve $script if it is a link + while(1) + { + my $linktext = readlink($script); + + ($RealScript,$RealBin) = fileparse($script); + last unless defined $linktext; + + $script = (is_abs_path($linktext)) + ? $linktext + : $RealBin . "/" . $linktext; + } + + # Get absolute paths to directories + $Bin = abs_path($Bin) if($Bin); + $RealBin = abs_path($RealBin) if($RealBin); + } + } +} + +1; # Keep require happy + diff --git a/gnu/usr.bin/perl/lib/Math/Trig.pm b/gnu/usr.bin/perl/lib/Math/Trig.pm new file mode 100644 index 00000000000..a1cbb072340 --- /dev/null +++ b/gnu/usr.bin/perl/lib/Math/Trig.pm @@ -0,0 +1,233 @@ +# +# Trigonometric functions, mostly inherited from Math::Complex. +# -- Jarkko Hietaniemi, April 1997 +# -- Raphael Manfredi, September 1996 (indirectly: because of Math::Complex) +# + +require Exporter; +package Math::Trig; + +use strict; + +use Math::Complex qw(:trig); + +use vars qw($VERSION $PACKAGE + @ISA + @EXPORT); + +@ISA = qw(Exporter); + +$VERSION = 1.00; + +my @angcnv = qw(rad2deg rad2grad + deg2rad deg2grad + grad2rad grad2deg); + +@EXPORT = (@{$Math::Complex::EXPORT_TAGS{'trig'}}, + @angcnv); + +use constant pi2 => 2 * pi; +use constant DR => pi2/360; +use constant RD => 360/pi2; +use constant DG => 400/360; +use constant GD => 360/400; +use constant RG => 400/pi2; +use constant GR => pi2/400; + +# +# Truncating remainder. +# + +sub remt ($$) { + # Oh yes, POSIX::fmod() would be faster. Possibly. If it is available. + $_[0] - $_[1] * int($_[0] / $_[1]); +} + +# +# Angle conversions. +# + +sub rad2deg ($) { remt(RD * $_[0], 360) } + +sub deg2rad ($) { remt(DR * $_[0], pi2) } + +sub grad2deg ($) { remt(GD * $_[0], 360) } + +sub deg2grad ($) { remt(DG * $_[0], 400) } + +sub rad2grad ($) { remt(RG * $_[0], 400) } + +sub grad2rad ($) { remt(GR * $_[0], pi2) } + +=head1 NAME + +Math::Trig - trigonometric functions + +=head1 SYNOPSIS + + use Math::Trig; + + $x = tan(0.9); + $y = acos(3.7); + $z = asin(2.4); + + $halfpi = pi/2; + + $rad = deg2rad(120); + +=head1 DESCRIPTION + +C<Math::Trig> defines many trigonometric functions not defined by the +core Perl which defines only the C<sin()> and C<cos()>. The constant +B<pi> is also defined as are a few convenience functions for angle +conversions. + +=head1 TRIGONOMETRIC FUNCTIONS + +The tangent + + tan + +The cofunctions of the sine, cosine, and tangent (cosec/csc and cotan/cot +are aliases) + + csc cosec sec cot cotan + +The arcus (also known as the inverse) functions of the sine, cosine, +and tangent + + asin acos atan + +The principal value of the arc tangent of y/x + + atan2(y, x) + +The arcus cofunctions of the sine, cosine, and tangent (acosec/acsc +and acotan/acot are aliases) + + acsc acosec asec acot acotan + +The hyperbolic sine, cosine, and tangent + + sinh cosh tanh + +The cofunctions of the hyperbolic sine, cosine, and tangent (cosech/csch +and cotanh/coth are aliases) + + csch cosech sech coth cotanh + +The arcus (also known as the inverse) functions of the hyperbolic +sine, cosine, and tangent + + asinh acosh atanh + +The arcus cofunctions of the hyperbolic sine, cosine, and tangent +(acsch/acosech and acoth/acotanh are aliases) + + acsch acosech asech acoth acotanh + +The trigonometric constant B<pi> is also defined. + + $pi2 = 2 * pi; + +=head2 ERRORS DUE TO DIVISION BY ZERO + +The following functions + + tan + sec + csc + cot + asec + acsc + tanh + sech + csch + coth + atanh + asech + acsch + acoth + +cannot be computed for all arguments because that would mean dividing +by zero or taking logarithm of zero. These situations cause fatal +runtime errors looking like this + + cot(0): Division by zero. + (Because in the definition of cot(0), the divisor sin(0) is 0) + Died at ... + +or + + atanh(-1): Logarithm of zero. + Died at... + +For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>, +C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the +C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the +C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the +C<tan>, C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k * +pi>, where I<k> is any integer. + +=head2 SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS + +Please note that some of the trigonometric functions can break out +from the B<real axis> into the B<complex plane>. For example +C<asin(2)> has no definition for plain real numbers but it has +definition for complex numbers. + +In Perl terms this means that supplying the usual Perl numbers (also +known as scalars, please see L<perldata>) as input for the +trigonometric functions might produce as output results that no more +are simple real numbers: instead they are complex numbers. + +The C<Math::Trig> handles this by using the C<Math::Complex> package +which knows how to handle complex numbers, please see L<Math::Complex> +for more information. In practice you need not to worry about getting +complex numbers as results because the C<Math::Complex> takes care of +details like for example how to display complex numbers. For example: + + print asin(2), "\n"; + +should produce something like this (take or leave few last decimals): + + 1.5707963267949-1.31695789692482i + +That is, a complex number with the real part of approximately C<1.571> +and the imaginary part of approximately C<-1.317>. + +=head1 ANGLE CONVERSIONS + +(Plane, 2-dimensional) angles may be converted with the following functions. + + $radians = deg2rad($degrees); + $radians = grad2rad($gradians); + + $degrees = rad2deg($radians); + $degrees = grad2deg($gradians); + + $gradians = deg2grad($degrees); + $gradians = rad2grad($radians); + +The full circle is 2 I<pi> radians or I<360> degrees or I<400> gradians. + +=head1 BUGS + +Saying C<use Math::Trig;> exports many mathematical routines in the +caller environment and even overrides some (C<sin>, C<cos>). This is +construed as a feature by the Authors, actually... ;-) + +The code is not optimized for speed, especially because we use +C<Math::Complex> and thus go quite near complex numbers while doing +the computations even when the arguments are not. This, however, +cannot be completely avoided if we want things like C<asin(2)> to give +an answer instead of giving a fatal runtime error. + +=head1 AUTHORS + +Jarkko Hietaniemi <F<jhi@iki.fi>> and +Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>>. + +=cut + +# eof diff --git a/gnu/usr.bin/perl/lib/Net/hostent.pm b/gnu/usr.bin/perl/lib/Net/hostent.pm new file mode 100644 index 00000000000..96b090dae5a --- /dev/null +++ b/gnu/usr.bin/perl/lib/Net/hostent.pm @@ -0,0 +1,149 @@ +package Net::hostent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(gethostbyname gethostbyaddr gethost); + @EXPORT_OK = qw( + $h_name @h_aliases + $h_addrtype $h_length + @h_addr_list $h_addr + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::hostent' => [ + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', +]; + +sub addr { shift->addr_list->[0] } + +sub populate (@) { + return unless @_; + my $hob = new(); + $h_name = $hob->[0] = $_[0]; + @h_aliases = @{ $hob->[1] } = split ' ', $_[1]; + $h_addrtype = $hob->[2] = $_[2]; + $h_length = $hob->[3] = $_[3]; + $h_addr = $_[4]; + @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ]; + return $hob; +} + +sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) } + +sub gethostbyaddr ($;$) { + my ($addr, $addrtype); + $addr = shift; + require Socket unless @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::gethostbyaddr($addr, $addrtype)) +} + +sub gethost($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &gethostbyaddr(Socket::inet_aton(shift)); + } else { + &gethostbyname; + } +} + +1; +__END__ + +=head1 NAME + +Net::hostent - by-name interface to Perl's built-in gethost*() functions + +=head1 SYNOPSIS + + use Net::hostnet; + +=head1 DESCRIPTION + +This module's default exports override the core gethostbyname() and +gethostbyaddr() functions, replacing them with versions that return +"Net::hostent" objects. This object has methods that return the similarly +named structure field name from the C's hostent structure from F<netdb.h>; +namely name, aliases, addrtype, length, and addr_list. The aliases and +addr_list methods return array reference, the rest scalars. The addr +method is equivalent to the zeroth element in the addr_list array +reference. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<h_>. Thus, C<$host_obj-E<gt>name()> corresponds to +$h_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $host_obj-E<gt>aliases() +}> would be simply @h_aliases. + +The gethost() funtion is a simple front-end that forwards a numeric +argument to gethostbyaddr() by way of Socket::inet_aton, and the rest +to gethostbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + + use Net::hostent; + use Socket; + + @ARGV = ('netscape.com') unless @ARGV; + + for $host ( @ARGV ) { + + unless ($h = gethost($host)) { + warn "$0: no such host: $host\n"; + next; + } + + printf "\n%s is %s%s\n", + $host, + lc($h->name) eq lc($host) ? "" : "*really* ", + $h->name; + + print "\taliases are ", join(", ", @{$h->aliases}), "\n" + if @{$h->aliases}; + + if ( @{$h->addr_list} > 1 ) { + my $i; + for $addr ( @{$h->addr_list} ) { + printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr); + } + } else { + printf "\taddress is [%s]\n", inet_ntoa($h->addr); + } + + if ($h = gethostbyaddr($h->addr)) { + if (lc($h->name) ne lc($host)) { + printf "\tThat addr reverses to host %s!\n", $h->name; + $host = $h->name; + redo; + } + } + } + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/Net/netent.pm b/gnu/usr.bin/perl/lib/Net/netent.pm new file mode 100644 index 00000000000..b82447cad71 --- /dev/null +++ b/gnu/usr.bin/perl/lib/Net/netent.pm @@ -0,0 +1,167 @@ +package Net::netent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(getnetbyname getnetbyaddr getnet); + @EXPORT_OK = qw( + $n_name @n_aliases + $n_addrtype $n_net + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::netent' => [ + name => '$', + aliases => '@', + addrtype => '$', + net => '$', +]; + +sub populate (@) { + return unless @_; + my $nob = new(); + $n_name = $nob->[0] = $_[0]; + @n_aliases = @{ $nob->[1] } = split ' ', $_[1]; + $n_addrtype = $nob->[2] = $_[2]; + $n_net = $nob->[3] = $_[3]; + return $nob; +} + +sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) } + +sub getnetbyaddr ($;$) { + my ($net, $addrtype); + $net = shift; + require Socket if @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::getnetbyaddr($net, $addrtype)) +} + +sub getnet($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &getnetbyaddr(Socket::inet_aton(shift)); + } else { + &getnetbyname; + } +} + +1; +__END__ + +=head1 NAME + +Net::netent - by-name interface to Perl's built-in getnet*() functions + +=head1 SYNOPSIS + + use Net::netent qw(:FIELDS); + getnetbyname("loopback") or die "bad net"; + printf "%s is %08X\n", $n_name, $n_net; + + use Net::netent; + + $n = getnetbyname("loopback") or die "bad net"; + { # there's gotta be a better way, eh? + @bytes = unpack("C4", pack("N", $n->net)); + shift @bytes while @bytes && $bytes[0] == 0; + } + printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes; + +=head1 DESCRIPTION + +This module's default exports override the core getnetbyname() and +getnetbyaddr() functions, replacing them with versions that return +"Net::netent" objects. This object has methods that return the similarly +named structure field name from the C's netent structure from F<netdb.h>; +namely name, aliases, addrtype, and net. The aliases +method returns an array reference, the rest scalars. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to +$n_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $net_obj-E<gt>aliases() +}> would be simply @n_aliases. + +The getnet() funtion is a simple front-end that forwards a numeric +argument to getnetbyaddr(), and the rest +to getnetbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + +The getnet() functions do this in the Perl core: + + sv_setiv(sv, (I32)nent->n_net); + +The gethost() functions do this in the Perl core: + + sv_setpvn(sv, hent->h_addr, len); + +That means that the address comes back in binary for the +host functions, and as a regular perl integer for the net ones. +This seems a bug, but here's how to deal with it: + + use strict; + use Socket; + use Net::netent; + + @ARGV = ('loopback') unless @ARGV; + + my($n, $net); + + for $net ( @ARGV ) { + + unless ($n = getnetbyname($net)) { + warn "$0: no such net: $net\n"; + next; + } + + printf "\n%s is %s%s\n", + $net, + lc($n->name) eq lc($net) ? "" : "*really* ", + $n->name; + + print "\taliases are ", join(", ", @{$n->aliases}), "\n" + if @{$n->aliases}; + + # this is stupid; first, why is this not in binary? + # second, why am i going through these convolutions + # to make it looks right + { + my @a = unpack("C4", pack("N", $n->net)); + shift @a while @a && $a[0] == 0; + printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a; + } + + if ($n = getnetbyaddr($n->net)) { + if (lc($n->name) ne lc($net)) { + printf "\tThat addr reverses to net %s!\n", $n->name; + $net = $n->name; + redo; + } + } + } + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/Net/protoent.pm b/gnu/usr.bin/perl/lib/Net/protoent.pm new file mode 100644 index 00000000000..737ff5a33bc --- /dev/null +++ b/gnu/usr.bin/perl/lib/Net/protoent.pm @@ -0,0 +1,94 @@ +package Net::protoent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(getprotobyname getprotobynumber getprotoent); + @EXPORT_OK = qw( $p_name @p_aliases $p_proto ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::protoent' => [ + name => '$', + aliases => '@', + proto => '$', +]; + +sub populate (@) { + return unless @_; + my $pob = new(); + $p_name = $pob->[0] = $_[0]; + @p_aliases = @{ $pob->[1] } = split ' ', $_[1]; + $p_proto = $pob->[2] = $_[2]; + return $pob; +} + +sub getprotoent ( ) { populate(CORE::getprotoent()) } +sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) } +sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) } + +sub getproto ($;$) { + no strict 'refs'; + return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_); +} + +1; + +__END__ + +=head1 NAME + +Net::protoent - by-name interface to Perl's built-in getproto*() functions + +=head1 SYNOPSIS + + use Net::protoent; + $p = getprotobyname(shift || 'tcp') || die "no proto"; + printf "proto for %s is %d, aliases are %s\n", + $p->name, $p->proto, "@{$p->aliases}"; + + use Net::protoent qw(:FIELDS); + getprotobyname(shift || 'tcp') || die "no proto"; + print "proto for $p_name is $p_proto, aliases are @p_aliases\n"; + +=head1 DESCRIPTION + +This module's default exports override the core getprotoent(), +getprotobyname(), and getnetbyport() functions, replacing them with +versions that return "Net::protoent" objects. They take default +second arguments of "tcp". This object has methods that return the +similarly named structure field name from the C's protoent structure +from F<netdb.h>; namely name, aliases, and proto. The aliases method +returns an array reference, the rest scalars. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<p_>. Thus, C<$proto_obj-E<gt>name()> corresponds to +$p_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $proto_obj-E<gt>aliases() +}> would be simply @p_aliases. + +The getproto() function is a simple front-end that forwards a numeric +argument to getprotobyport(), and the rest to getprotobyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/Net/servent.pm b/gnu/usr.bin/perl/lib/Net/servent.pm new file mode 100644 index 00000000000..fb85dd04bfa --- /dev/null +++ b/gnu/usr.bin/perl/lib/Net/servent.pm @@ -0,0 +1,111 @@ +package Net::servent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(getservbyname getservbyport getservent getserv); + @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::servent' => [ + name => '$', + aliases => '@', + port => '$', + proto => '$', +]; + +sub populate (@) { + return unless @_; + my $sob = new(); + $s_name = $sob->[0] = $_[0]; + @s_aliases = @{ $sob->[1] } = split ' ', $_[1]; + $s_port = $sob->[2] = $_[2]; + $s_proto = $sob->[3] = $_[3]; + return $sob; +} + +sub getservent ( ) { populate(CORE::getservent()) } +sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) } +sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) } + +sub getserv ($;$) { + no strict 'refs'; + return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_); +} + +1; + +__END__ + +=head1 NAME + +Net::servent - by-name interface to Perl's built-in getserv*() functions + +=head1 SYNOPSIS + + use Net::servent; + $s = getservbyname(shift || 'ftp') || die "no service"; + printf "port for %s is %s, aliases are %s\n", + $s->name, $s->port, "@{$s->aliases}"; + + use Net::servent qw(:FIELDS); + getservbyname(shift || 'ftp') || die "no service"; + print "port for $s_name is $s_port, aliases are @s_aliases\n"; + +=head1 DESCRIPTION + +This module's default exports override the core getservent(), +getservbyname(), and +getnetbyport() functions, replacing them with versions that return +"Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly +named structure field name from the C's servent structure from F<netdb.h>; +namely name, aliases, port, and proto. The aliases +method returns an array reference, the rest scalars. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<n_>. Thus, C<$serv_obj-E<gt>name()> corresponds to +$s_name if you import the fields. Array references are available as +regular array variables, so for example C<@{ $serv_obj-E<gt>aliases() +}> would be simply @s_aliases. + +The getserv() function is a simple front-end that forwards a numeric +argument to getservbyport(), and the rest to getservbyname(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 EXAMPLES + + use Net::servent qw(:FIELDS); + + while (@ARGV) { + my ($service, $proto) = ((split m!/!, shift), 'tcp'); + my $valet = getserv($service, $proto); + unless ($valet) { + warn "$0: No service: $service/$proto\n" + next; + } + printf "service $service/$proto is port %d\n", $valet->port; + print "alias are @s_aliases\n" if @s_aliases; + } + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/Pod/Html.pm b/gnu/usr.bin/perl/lib/Pod/Html.pm new file mode 100644 index 00000000000..ffeb0b21361 --- /dev/null +++ b/gnu/usr.bin/perl/lib/Pod/Html.pm @@ -0,0 +1,1523 @@ +package Pod::Html; + +use Pod::Functions; +use Getopt::Long; # package for handling command-line parameters +require Exporter; +@ISA = Exporter; +@EXPORT = qw(pod2html htmlify); +use Cwd; + +use Carp; + +use strict; + +=head1 NAME + +Pod::HTML - module to convert pod files to HTML + +=head1 SYNOPSIS + + use Pod::HTML; + pod2html([options]); + +=head1 DESCRIPTION + +Converts files from pod format (see L<perlpod>) to HTML format. It +can automatically generate indexes and cross-references, and it keeps +a cache of things it knows how to cross-reference. + +=head1 ARGUMENTS + +Pod::Html takes the following arguments: + +=over 4 + +=item help + + --help + +Displays the usage message. + +=item htmlroot + + --htmlroot=name + +Sets the base URL for the HTML files. When cross-references are made, +the HTML root is prepended to the URL. + +=item infile + + --infile=name + +Specify the pod file to convert. Input is taken from STDIN if no +infile is specified. + +=item outfile + + --outfile=name + +Specify the HTML file to create. Output goes to STDOUT if no outfile +is specified. + +=item podroot + + --podroot=name + +Specify the base directory for finding library pods. + +=item podpath + + --podpath=name:...:name + +Specify which subdirectories of the podroot contain pod files whose +HTML converted forms can be linked-to in cross-references. + +=item libpods + + --libpods=name:...:name + +List of page names (eg, "perlfunc") which contain linkable C<=item>s. + +=item netscape + + --netscape + +Use Netscape HTML directives when applicable. + +=item nonetscape + + --nonetscape + +Do not use Netscape HTML directives (default). + +=item index + + --index + +Generate an index at the top of the HTML file (default behaviour). + +=item noindex + + --noindex + +Do not generate an index at the top of the HTML file. + + +=item recurse + + --recurse + +Recurse into subdirectories specified in podpath (default behaviour). + +=item norecurse + + --norecurse + +Do not recurse into subdirectories specified in podpath. + +=item title + + --title=title + +Specify the title of the resulting HTML file. + +=item verbose + + --verbose + +Display progress messages. + +=back + +=head1 EXAMPLE + + pod2html("pod2html", + "--podpath=lib:ext:pod:vms", + "--podroot=/usr/src/perl", + "--htmlroot=/perl/nmanual", + "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop", + "--recurse", + "--infile=foo.pod", + "--outfile=/perl/nmanual/foo.html"); + +=head1 AUTHOR + +Tom Christiansen, E<lt>tchrist@perl.comE<gt>. + +=head1 BUGS + +Has trouble with C<> etc in = commands. + +=head1 SEE ALSO + +L<perlpod> + +=head1 COPYRIGHT + +This program is distributed under the Artistic License. + +=cut + +my $dircache = "pod2html-dircache"; +my $itemcache = "pod2html-itemcache"; + +my @begin_stack = (); # begin/end stack + +my @libpods = (); # files to search for links from C<> directives +my $htmlroot = "/"; # http-server base directory from which all + # relative paths in $podpath stem. +my $htmlfile = ""; # write to stdout by default +my $podfile = ""; # read from stdin by default +my @podpath = (); # list of directories containing library pods. +my $podroot = "."; # filesystem base directory from which all + # relative paths in $podpath stem. +my $recurse = 1; # recurse on subdirectories in $podpath. +my $verbose = 0; # not verbose by default +my $doindex = 1; # non-zero if we should generate an index +my $listlevel = 0; # current list depth +my @listitem = (); # stack of HTML commands to use when a =item is + # encountered. the top of the stack is the + # current list. +my @listdata = (); # similar to @listitem, but for the text after + # an =item +my @listend = (); # similar to @listitem, but the text to use to + # end the list. +my $ignore = 1; # whether or not to format text. we don't + # format text until we hit our first pod + # directive. + +my %items_named = (); # for the multiples of the same item in perlfunc +my @items_seen = (); +my $netscape = 0; # whether or not to use netscape directives. +my $title; # title to give the pod(s) +my $top = 1; # true if we are at the top of the doc. used + # to prevent the first <HR> directive. +my $paragraph; # which paragraph we're processing (used + # for error messages) +my %pages = (); # associative array used to find the location + # of pages referenced by L<> links. +my %sections = (); # sections within this page +my %items = (); # associative array used to find the location + # of =item directives referenced by C<> links +sub init_globals { +$dircache = "pod2html-dircache"; +$itemcache = "pod2html-itemcache"; + +@begin_stack = (); # begin/end stack + +@libpods = (); # files to search for links from C<> directives +$htmlroot = "/"; # http-server base directory from which all + # relative paths in $podpath stem. +$htmlfile = ""; # write to stdout by default +$podfile = ""; # read from stdin by default +@podpath = (); # list of directories containing library pods. +$podroot = "."; # filesystem base directory from which all + # relative paths in $podpath stem. +$recurse = 1; # recurse on subdirectories in $podpath. +$verbose = 0; # not verbose by default +$doindex = 1; # non-zero if we should generate an index +$listlevel = 0; # current list depth +@listitem = (); # stack of HTML commands to use when a =item is + # encountered. the top of the stack is the + # current list. +@listdata = (); # similar to @listitem, but for the text after + # an =item +@listend = (); # similar to @listitem, but the text to use to + # end the list. +$ignore = 1; # whether or not to format text. we don't + # format text until we hit our first pod + # directive. + +@items_seen = (); +%items_named = (); +$netscape = 0; # whether or not to use netscape directives. +$title = ''; # title to give the pod(s) +$top = 1; # true if we are at the top of the doc. used + # to prevent the first <HR> directive. +$paragraph = ''; # which paragraph we're processing (used + # for error messages) +%sections = (); # sections within this page + +# These are not reinitialised here but are kept as a cache. +# See get_cache and related cache management code. +#%pages = (); # associative array used to find the location + # of pages referenced by L<> links. +#%items = (); # associative array used to find the location + # of =item directives referenced by C<> links + +} + +sub pod2html { + local(@ARGV) = @_; + local($/); + local $_; + + init_globals(); + + # cache of %pages and %items from last time we ran pod2html + + #undef $opt_help if defined $opt_help; + + # parse the command-line parameters + parse_command_line(); + + # set some variables to their default values if necessary + local *POD; + unless (@ARGV && $ARGV[0]) { + $podfile = "-" unless $podfile; # stdin + open(POD, "<$podfile") + || die "$0: cannot open $podfile file for input: $!\n"; + } else { + $podfile = $ARGV[0]; # XXX: might be more filenames + *POD = *ARGV; + } + $htmlfile = "-" unless $htmlfile; # stdout + $htmlroot = "" if $htmlroot eq "/"; # so we don't get a // + + # read the pod a paragraph at a time + warn "Scanning for sections in input file(s)\n" if $verbose; + $/ = ""; + my @poddata = <POD>; + close(POD); + + # scan the pod for =head[1-6] directives and build an index + my $index = scan_headings(\%sections, @poddata); + + unless($index) { + warn "No pod in $podfile\n" if $verbose; + return; + } + + # open the output file + open(HTML, ">$htmlfile") + || die "$0: cannot open $htmlfile file for output: $!\n"; + + # put a title in the HTML file + $title = ''; + TITLE_SEARCH: { + for (my $i = 0; $i < @poddata; $i++) { + if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { + for my $para ( @poddata[$i, $i+1] ) { + last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+\s*.*)/s; + } + } + + } + } + if (!$title and $podfile =~ /\.pod$/) { + # probably a split pod so take first =head[12] as title + for (my $i = 0; $i < @poddata; $i++) { + last if ($title) = $poddata[$i] =~ /^=head[12]\s*(.*)/; + } + warn "adopted '$title' as title for $podfile\n" + if $verbose and $title; + } + unless ($title) { + warn "$0: no title for $podfile"; + $podfile =~ /^(.*)(\.[^.\/]+)?$/; + $title = ($podfile eq "-" ? 'No Title' : $1); + warn "using $title" if $verbose; + } + print HTML <<END_OF_HEAD; + <HTML> + <HEAD> + <TITLE>$title</TITLE> + </HEAD> + + <BODY> + +END_OF_HEAD + + # load/reload/validate/cache %pages and %items + get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse); + + # scan the pod for =item directives + scan_items("", \%items, @poddata); + + # put an index at the top of the file. note, if $doindex is 0 we + # still generate an index, but surround it with an html comment. + # that way some other program can extract it if desired. + $index =~ s/--+/-/g; + print HTML "<!-- INDEX BEGIN -->\n"; + print HTML "<!--\n" unless $doindex; + print HTML $index; + print HTML "-->\n" unless $doindex; + print HTML "<!-- INDEX END -->\n\n"; + print HTML "<HR>\n" if $doindex; + + # now convert this file + warn "Converting input file\n" if $verbose; + foreach my $i (0..$#poddata) { + $_ = $poddata[$i]; + $paragraph = $i+1; + if (/^(=.*)/s) { # is it a pod directive? + $ignore = 0; + $_ = $1; + if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin + process_begin($1, $2); + } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end + process_end($1, $2); + } elsif (/^=cut/) { # =cut + process_cut(); + } elsif (/^=pod/) { # =pod + process_pod(); + } else { + next if @begin_stack && $begin_stack[-1] ne 'html'; + + if (/^=(head[1-6])\s+(.*)/s) { # =head[1-6] heading + process_head($1, $2); + } elsif (/^=item\s*(.*)/sm) { # =item text + process_item($1); + } elsif (/^=over\s*(.*)/) { # =over N + process_over(); + } elsif (/^=back/) { # =back + process_back(); + } elsif (/^=for\s+(\S+)\s+(.*)/si) {# =for + process_for($1,$2); + } else { + /^=(\S*)\s*/; + warn "$0: $podfile: unknown pod directive '$1' in " + . "paragraph $paragraph. ignoring.\n"; + } + } + $top = 0; + } + else { + next if $ignore; + next if @begin_stack && $begin_stack[-1] ne 'html'; + my $text = $_; + process_text(\$text, 1); + print HTML "$text\n<P>\n\n"; + } + } + + # finish off any pending directives + finish_list(); + print HTML <<END_OF_TAIL; + </BODY> + + </HTML> +END_OF_TAIL + + # close the html file + close(HTML); + + warn "Finished\n" if $verbose; +} + +############################################################################## + +my $usage; # see below +sub usage { + my $podfile = shift; + warn "$0: $podfile: @_\n" if @_; + die $usage; +} + +$usage =<<END_OF_USAGE; +Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name> + --podpath=<name>:...:<name> --podroot=<name> + --libpods=<name>:...:<name> --recurse --verbose --index + --netscape --norecurse --noindex + + --flush - flushes the item and directory caches. + --help - prints this message. + --htmlroot - http-server base directory from which all relative paths + in podpath stem (default is /). + --index - generate an index at the top of the resulting html + (default). + --infile - filename for the pod to convert (input taken from stdin + by default). + --libpods - colon-separated list of pages to search for =item pod + directives in as targets of C<> and implicit links (empty + by default). note, these are not filenames, but rather + page names like those that appear in L<> links. + --netscape - will use netscape html directives when applicable. + --nonetscape - will not use netscape directives (default). + --outfile - filename for the resulting html file (output sent to + stdout by default). + --podpath - colon-separated list of directories containing library + pods. empty by default. + --podroot - filesystem base directory from which all relative paths + in podpath stem (default is .). + --noindex - don't generate an index at the top of the resulting html. + --norecurse - don't recurse on those subdirectories listed in podpath. + --recurse - recurse on those subdirectories listed in podpath + (default behavior). + --title - title that will appear in resulting html file. + --verbose - self-explanatory + +END_OF_USAGE + +sub parse_command_line { + my ($opt_flush,$opt_help,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose); + my $result = GetOptions( + 'flush' => \$opt_flush, + 'help' => \$opt_help, + 'htmlroot=s' => \$opt_htmlroot, + 'index!' => \$opt_index, + 'infile=s' => \$opt_infile, + 'libpods=s' => \$opt_libpods, + 'netscape!' => \$opt_netscape, + 'outfile=s' => \$opt_outfile, + 'podpath=s' => \$opt_podpath, + 'podroot=s' => \$opt_podroot, + 'norecurse' => \$opt_norecurse, + 'recurse!' => \$opt_recurse, + 'title=s' => \$opt_title, + 'verbose' => \$opt_verbose, + ); + usage("-", "invalid parameters") if not $result; + + usage("-") if defined $opt_help; # see if the user asked for help + $opt_help = ""; # just to make -w shut-up. + + $podfile = $opt_infile if defined $opt_infile; + $htmlfile = $opt_outfile if defined $opt_outfile; + + @podpath = split(":", $opt_podpath) if defined $opt_podpath; + @libpods = split(":", $opt_libpods) if defined $opt_libpods; + + warn "Flushing item and directory caches\n" + if $opt_verbose && defined $opt_flush; + unlink($dircache, $itemcache) if defined $opt_flush; + + $htmlroot = $opt_htmlroot if defined $opt_htmlroot; + $podroot = $opt_podroot if defined $opt_podroot; + + $doindex = $opt_index if defined $opt_index; + $recurse = $opt_recurse if defined $opt_recurse; + $title = $opt_title if defined $opt_title; + $verbose = defined $opt_verbose ? 1 : 0; + $netscape = $opt_netscape if defined $opt_netscape; +} + + +my $saved_cache_key; + +sub get_cache { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + my @cache_key_args = @_; + + # A first-level cache: + # Don't bother reading the cache files if they still apply + # and haven't changed since we last read them. + + my $this_cache_key = cache_key(@cache_key_args); + + return if $saved_cache_key and $this_cache_key eq $saved_cache_key; + + # load the cache of %pages and %items if possible. $tests will be + # non-zero if successful. + my $tests = 0; + if (-f $dircache && -f $itemcache) { + warn "scanning for item cache\n" if $verbose; + $tests = load_cache($dircache, $itemcache, $podpath, $podroot); + } + + # if we didn't succeed in loading the cache then we must (re)build + # %pages and %items. + if (!$tests) { + warn "scanning directories in pod-path\n" if $verbose; + scan_podpath($podroot, $recurse, 0); + } + $saved_cache_key = cache_key(@cache_key_args); +} + +sub cache_key { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + return join('!', $dircache, $itemcache, $recurse, + @$podpath, $podroot, stat($dircache), stat($itemcache)); +} + +# +# load_cache - tries to find if the caches stored in $dircache and $itemcache +# are valid caches of %pages and %items. if they are valid then it loads +# them and returns a non-zero value. +# + +sub load_cache { + my($dircache, $itemcache, $podpath, $podroot) = @_; + my($tests); + local $_; + + $tests = 0; + + open(CACHE, "<$itemcache") || + die "$0: error opening $itemcache for reading: $!\n"; + $/ = "\n"; + + # is it the same podpath? + $_ = <CACHE>; + chomp($_); + $tests++ if (join(":", @$podpath) eq $_); + + # is it the same podroot? + $_ = <CACHE>; + chomp($_); + $tests++ if ($podroot eq $_); + + # load the cache if its good + if ($tests != 2) { + close(CACHE); + return 0; + } + + warn "loading item cache\n" if $verbose; + while (<CACHE>) { + /(.*?) (.*)$/; + $items{$1} = $2; + } + close(CACHE); + + warn "scanning for directory cache\n" if $verbose; + open(CACHE, "<$dircache") || + die "$0: error opening $dircache for reading: $!\n"; + $/ = "\n"; + $tests = 0; + + # is it the same podpath? + $_ = <CACHE>; + chomp($_); + $tests++ if (join(":", @$podpath) eq $_); + + # is it the same podroot? + $_ = <CACHE>; + chomp($_); + $tests++ if ($podroot eq $_); + + # load the cache if its good + if ($tests != 2) { + close(CACHE); + return 0; + } + + warn "loading directory cache\n" if $verbose; + while (<CACHE>) { + /(.*?) (.*)$/; + $pages{$1} = $2; + } + + close(CACHE); + + return 1; +} + +# +# scan_podpath - scans the directories specified in @podpath for directories, +# .pod files, and .pm files. it also scans the pod files specified in +# @libpods for =item directives. +# +sub scan_podpath { + my($podroot, $recurse, $append) = @_; + my($pwd, $dir); + my($libpod, $dirname, $pod, @files, @poddata); + + unless($append) { + %items = (); + %pages = (); + } + + # scan each directory listed in @podpath + $pwd = getcwd(); + chdir($podroot) + || die "$0: error changing to directory $podroot: $!\n"; + foreach $dir (@podpath) { + scan_dir($dir, $recurse); + } + + # scan the pods listed in @libpods for =item directives + foreach $libpod (@libpods) { + # if the page isn't defined then we won't know where to find it + # on the system. + next unless defined $pages{$libpod} && $pages{$libpod}; + + # if there is a directory then use the .pod and .pm files within it. + if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) { + # find all the .pod and .pm files within the directory + $dirname = $1; + opendir(DIR, $dirname) || + die "$0: error opening directory $dirname: $!\n"; + @files = grep(/(\.pod|\.pm)$/ && ! -d $_, readdir(DIR)); + closedir(DIR); + + # scan each .pod and .pm file for =item directives + foreach $pod (@files) { + open(POD, "<$dirname/$pod") || + die "$0: error opening $dirname/$pod for input: $!\n"; + @poddata = <POD>; + close(POD); + + scan_items("$dirname/$pod", @poddata); + } + + # use the names of files as =item directives too. + foreach $pod (@files) { + $pod =~ /^(.*)(\.pod|\.pm)$/; + $items{$1} = "$dirname/$1.html" if $1; + } + } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ || + $pages{$libpod} =~ /([^:]*\.pm):/) { + # scan the .pod or .pm file for =item directives + $pod = $1; + open(POD, "<$pod") || + die "$0: error opening $pod for input: $!\n"; + @poddata = <POD>; + close(POD); + + scan_items("$pod", @poddata); + } else { + warn "$0: shouldn't be here (line ".__LINE__."\n"; + } + } + @poddata = (); # clean-up a bit + + chdir($pwd) + || die "$0: error changing to directory $pwd: $!\n"; + + # cache the item list for later use + warn "caching items for later use\n" if $verbose; + open(CACHE, ">$itemcache") || + die "$0: error open $itemcache for writing: $!\n"; + + print CACHE join(":", @podpath) . "\n$podroot\n"; + foreach my $key (keys %items) { + print CACHE "$key $items{$key}\n"; + } + + close(CACHE); + + # cache the directory list for later use + warn "caching directories for later use\n" if $verbose; + open(CACHE, ">$dircache") || + die "$0: error open $dircache for writing: $!\n"; + + print CACHE join(":", @podpath) . "\n$podroot\n"; + foreach my $key (keys %pages) { + print CACHE "$key $pages{$key}\n"; + } + + close(CACHE); +} + +# +# scan_dir - scans the directory specified in $dir for subdirectories, .pod +# files, and .pm files. notes those that it finds. this information will +# be used later in order to figure out where the pages specified in L<> +# links are on the filesystem. +# +sub scan_dir { + my($dir, $recurse) = @_; + my($t, @subdirs, @pods, $pod, $dirname, @dirs); + local $_; + + @subdirs = (); + @pods = (); + + opendir(DIR, $dir) || + die "$0: error opening directory $dir: $!\n"; + while (defined($_ = readdir(DIR))) { + if (-d "$dir/$_" && $_ ne "." && $_ ne "..") { # directory + $pages{$_} = "" unless defined $pages{$_}; + $pages{$_} .= "$dir/$_:"; + push(@subdirs, $_); + } elsif (/\.pod$/) { # .pod + s/\.pod$//; + $pages{$_} = "" unless defined $pages{$_}; + $pages{$_} .= "$dir/$_.pod:"; + push(@pods, "$dir/$_.pod"); + } elsif (/\.pm$/) { # .pm + s/\.pm$//; + $pages{$_} = "" unless defined $pages{$_}; + $pages{$_} .= "$dir/$_.pm:"; + push(@pods, "$dir/$_.pm"); + } + } + closedir(DIR); + + # recurse on the subdirectories if necessary + if ($recurse) { + foreach my $subdir (@subdirs) { + scan_dir("$dir/$subdir", $recurse); + } + } +} + +# +# scan_headings - scan a pod file for head[1-6] tags, note the tags, and +# build an index. +# +sub scan_headings { + my($sections, @data) = @_; + my($tag, $which_head, $title, $listdepth, $index); + + # here we need local $ignore = 0; + # unfortunately, we can't have it, because $ignore is lexical + $ignore = 0; + + $listdepth = 0; + $index = ""; + + # scan for =head directives, note their name, and build an index + # pointing to each of them. + foreach my $line (@data) { + if ($line =~ /^=(head)([1-6])\s+(.*)/) { + ($tag,$which_head, $title) = ($1,$2,$3); + chomp($title); + $$sections{htmlify(0,$title)} = 1; + + if ($which_head > $listdepth) { + $index .= "\n" . ("\t" x $listdepth) . "<UL>\n"; + } elsif ($which_head < $listdepth) { + $listdepth--; + $index .= "\n" . ("\t" x $listdepth) . "</UL>\n"; + } + $listdepth = $which_head; + + $index .= "\n" . ("\t" x $listdepth) . "<LI>" . + "<A HREF=\"#" . htmlify(0,$title) . "\">" . + process_text(\$title, 0) . "</A>"; + } + } + + # finish off the lists + while ($listdepth--) { + $index .= "\n" . ("\t" x $listdepth) . "</UL>\n"; + } + + # get rid of bogus lists + $index =~ s,\t*<UL>\s*</UL>\n,,g; + + $ignore = 1; # restore old value; + + return $index; +} + +# +# scan_items - scans the pod specified by $pod for =item directives. we +# will use this information later on in resolving C<> links. +# +sub scan_items { + my($pod, @poddata) = @_; + my($i, $item); + local $_; + + $pod =~ s/\.pod$//; + $pod .= ".html" if $pod; + + foreach $i (0..$#poddata) { + $_ = $poddata[$i]; + + # remove any formatting instructions + s,[A-Z]<([^<>]*)>,$1,g; + + # figure out what kind of item it is and get the first word of + # it's name. + if (/^=item\s+(\w*)\s*.*$/s) { + if ($1 eq "*") { # bullet list + /\A=item\s+\*\s*(.*?)\s*\Z/s; + $item = $1; + } elsif ($1 =~ /^[0-9]+/) { # numbered list + /\A=item\s+[0-9]+\.?(.*?)\s*\Z/s; + $item = $1; + } else { +# /\A=item\s+(.*?)\s*\Z/s; + /\A=item\s+(\w*)/s; + $item = $1; + } + + $items{$item} = "$pod" if $item; + } + } +} + +# +# process_head - convert a pod head[1-6] tag and convert it to HTML format. +# +sub process_head { + my($tag, $heading) = @_; + my $firstword; + + # figure out the level of the =head + $tag =~ /head([1-6])/; + my $level = $1; + + # can't have a heading full of spaces and speechmarks and so on + $firstword = $heading; $firstword =~ s/\s*(\w+)\s.*/$1/; + + print HTML "<P>\n" unless $listlevel; + print HTML "<HR>\n" unless $listlevel || $top; + print HTML "<H$level>"; # unless $listlevel; + #print HTML "<H$level>" unless $listlevel; + my $convert = $heading; process_text(\$convert, 0); + print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>"; + print HTML "</H$level>"; # unless $listlevel; + print HTML "\n"; +} + +# +# process_item - convert a pod item tag and convert it to HTML format. +# +sub process_item { + my $text = $_[0]; + my($i, $quote, $name); + + my $need_preamble = 0; + my $this_entry; + + + # lots of documents start a list without doing an =over. this is + # bad! but, the proper thing to do seems to be to just assume + # they did do an =over. so warn them once and then continue. + warn "$0: $podfile: unexpected =item directive in paragraph $paragraph. ignoring.\n" + unless $listlevel; + process_over() unless $listlevel; + + return unless $listlevel; + + # remove formatting instructions from the text + 1 while $text =~ s/[A-Z]<([^<>]*)>/$1/g; + pre_escape(\$text); + + $need_preamble = $items_seen[$listlevel]++ == 0; + + # check if this is the first =item after an =over + $i = $listlevel - 1; + my $need_new = $listlevel >= @listitem; + + if ($text =~ /\A\*/) { # bullet + + if ($need_preamble) { + push(@listend, "</UL>"); + print HTML "<UL>\n"; + } + + print HTML "<LI><STRONG>"; + $text =~ /\A\*\s*(.*)\Z/s; + print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++; + $quote = 1; + #print HTML process_puretext($1, \$quote); + print HTML $1; + print HTML "</A>" if $1; + print HTML "</STRONG>"; + + } elsif ($text =~ /\A[0-9#]+/) { # numbered list + + if ($need_preamble) { + push(@listend, "</OL>"); + print HTML "<OL>\n"; + } + + print HTML "<LI><STRONG>"; + $text =~ /\A[0-9]+\.?(.*)\Z/s; + print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1; + $quote = 1; + #print HTML process_puretext($1, \$quote); + print HTML $1 if $1; + print HTML "</A>" if $1; + print HTML "</STRONG>"; + + } else { # all others + + if ($need_preamble) { + push(@listend, '</DL>'); + print HTML "<DL>\n"; + } + + print HTML "<DT><STRONG>"; + print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">" + if $text && !$items_named{($text =~ /(\S+)/)[0]}++; + # preceding craziness so that the duplicate leading bits in + # perlfunc work to find just the first one. otherwise + # open etc would have many names + $quote = 1; + #print HTML process_puretext($text, \$quote); + print HTML $text; + print HTML "</A>" if $text; + print HTML "</STRONG>"; + + print HTML '<DD>'; + } + + print HTML "\n"; +} + +# +# process_over - process a pod over tag and start a corresponding HTML +# list. +# +sub process_over { + # start a new list + $listlevel++; +} + +# +# process_back - process a pod back tag and convert it to HTML format. +# +sub process_back { + warn "$0: $podfile: unexpected =back directive in paragraph $paragraph. ignoring.\n" + unless $listlevel; + return unless $listlevel; + + # close off the list. note, I check to see if $listend[$listlevel] is + # defined because an =item directive may have never appeared and thus + # $listend[$listlevel] may have never been initialized. + $listlevel--; + print HTML $listend[$listlevel] if defined $listend[$listlevel]; + print HTML "\n"; + + # don't need the corresponding perl code anymore + pop(@listitem); + pop(@listdata); + pop(@listend); + + pop(@items_seen); +} + +# +# process_cut - process a pod cut tag, thus stop ignoring pod directives. +# +sub process_cut { + $ignore = 1; +} + +# +# process_pod - process a pod pod tag, thus ignore pod directives until we see a +# corresponding cut. +# +sub process_pod { + # no need to set $ignore to 0 cause the main loop did it +} + +# +# process_for - process a =for pod tag. if it's for html, split +# it out verbatim, otherwise ignore it. +# +sub process_for { + my($whom, $text) = @_; + if ( $whom =~ /^(pod2)?html$/i) { + print HTML $text; + } +} + +# +# process_begin - process a =begin pod tag. this pushes +# whom we're beginning on the begin stack. if there's a +# begin stack, we only print if it us. +# +sub process_begin { + my($whom, $text) = @_; + $whom = lc($whom); + push (@begin_stack, $whom); + if ( $whom =~ /^(pod2)?html$/) { + print HTML $text if $text; + } +} + +# +# process_end - process a =end pod tag. pop the +# begin stack. die if we're mismatched. +# +sub process_end { + my($whom, $text) = @_; + $whom = lc($whom); + if ($begin_stack[-1] ne $whom ) { + die "Unmatched begin/end at chunk $paragraph\n" + } + pop @begin_stack; +} + +# +# process_text - handles plaintext that appears in the input pod file. +# there may be pod commands embedded within the text so those must be +# converted to html commands. +# +sub process_text { + my($text, $escapeQuotes) = @_; + my($result, $rest, $s1, $s2, $s3, $s4, $match, $bf); + my($podcommand, $params, $tag, $quote); + + return if $ignore; + + $quote = 0; # status of double-quote conversion + $result = ""; + $rest = $$text; + + if ($rest =~ /^\s+/) { # preformatted text, no pod directives + $rest =~ s/\n+\Z//; + $rest =~ s#.*# + my $line = $&; + 1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e; + $line; + #eg; + + $rest =~ s/&/&/g; + $rest =~ s/</</g; + $rest =~ s/>/>/g; + $rest =~ s/"/"/g; + + # try and create links for all occurrences of perl.* within + # the preformatted text. + $rest =~ s{ + (\s*)(perl\w+) + }{ + if (defined $pages{$2}) { # is a link + qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>); + } else { + "$1$2"; + } + }xeg; + $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g; + + my $urls = '(' . join ('|', qw{ + http + telnet + mailto + news + gopher + file + wais + ftp + } ) + . ')'; + + my $ltrs = '\w'; + my $gunk = '/#~:.?+=&%@!\-'; + my $punc = '.:?\-'; + my $any = "${ltrs}${gunk}${punc}"; + + $rest =~ s{ + \b # start at word boundary + ( # begin $1 { + $urls : # need resource and a colon + [$any] +? # followed by on or more + # of any valid character, but + # be conservative and take only + # what you need to.... + ) # end $1 } + (?= # look-ahead non-consumptive assertion + [$punc]* # either 0 or more puntuation + [^$any] # followed by a non-url char + | # or else + $ # then end of the string + ) + }{<A HREF="$1">$1</A>}igox; + + $result = "<PRE>" # text should be as it is (verbatim) + . "$rest\n" + . "</PRE>\n"; + } else { # formatted text + # parse through the string, stopping each time we find a + # pod-escape. once the string has been throughly processed + # we can output it. + while ($rest) { + # check to see if there are any possible pod directives in + # the remaining part of the text. + if ($rest =~ m/[BCEIFLSZ]</) { + warn "\$rest\t= $rest\n" unless + $rest =~ /\A + ([^<]*?) + ([BCEIFLSZ]?) + < + (.*)\Z/xs; + + $s1 = $1; # pure text + $s2 = $2; # the type of pod-escape that follows + $s3 = '<'; # '<' + $s4 = $3; # the rest of the string + } else { + $s1 = $rest; + $s2 = ""; + $s3 = ""; + $s4 = ""; + } + + if ($s3 eq '<' && $s2) { # a pod-escape + $result .= ($escapeQuotes ? process_puretext($s1, \$quote) : $s1); + $podcommand = "$s2<"; + $rest = $s4; + + # find the matching '>' + $match = 1; + $bf = 0; + while ($match && !$bf) { + $bf = 1; + if ($rest =~ /\A([^<>]*[BCEIFLSZ]<)(.*)\Z/s) { + $bf = 0; + $match++; + $podcommand .= $1; + $rest = $2; + } elsif ($rest =~ /\A([^>]*>)(.*)\Z/s) { + $bf = 0; + $match--; + $podcommand .= $1; + $rest = $2; + } + } + + if ($match != 0) { + warn <<WARN; +$0: $podfile: cannot find matching > for $s2 in paragraph $paragraph. +WARN + $result .= substr $podcommand, 0, 2; + $rest = substr($podcommand, 2) . $rest; + next; + } + + # pull out the parameters to the pod-escape + $podcommand =~ /^([BCFEILSZ]?)<(.*)>$/s; + $tag = $1; + $params = $2; + + # process the text within the pod-escape so that any escapes + # which must occur do. + process_text(\$params, 0) unless $tag eq 'L'; + + $s1 = $params; + if (!$tag || $tag eq " ") { # <> : no tag + $s1 = "<$params>"; + } elsif ($tag eq "L") { # L<> : link + $s1 = process_L($params); + } elsif ($tag eq "I" || # I<> : italicize text + $tag eq "B" || # B<> : bold text + $tag eq "F") { # F<> : file specification + $s1 = process_BFI($tag, $params); + } elsif ($tag eq "C") { # C<> : literal code + $s1 = process_C($params, 1); + } elsif ($tag eq "E") { # E<> : escape + $s1 = process_E($params); + } elsif ($tag eq "Z") { # Z<> : zero-width character + $s1 = process_Z($params); + } elsif ($tag eq "S") { # S<> : non-breaking space + $s1 = process_S($params); + } elsif ($tag eq "X") { # S<> : non-breaking space + $s1 = process_X($params); + } else { + warn "$0: $podfile: unhandled tag '$tag' in paragraph $paragraph\n"; + } + + $result .= "$s1"; + } else { + # for pure text we must deal with implicit links and + # double-quotes among other things. + $result .= ($escapeQuotes ? process_puretext("$s1$s2$s3", \$quote) : "$s1$s2$s3"); + $rest = $s4; + } + } + } + $$text = $result; +} + +sub html_escape { + my $rest = $_[0]; + $rest =~ s/&/&/g; + $rest =~ s/</</g; + $rest =~ s/>/>/g; + $rest =~ s/"/"/g; + return $rest; +} + +# +# process_puretext - process pure text (without pod-escapes) converting +# double-quotes and handling implicit C<> links. +# +sub process_puretext { + my($text, $quote) = @_; + my(@words, $result, $rest, $lead, $trail); + + # convert double-quotes to single-quotes + $text =~ s/\A([^"]*)"/$1''/s if $$quote; + while ($text =~ s/\A([^"]*)["]([^"]*)["]/$1``$2''/sg) {} + + $$quote = ($text =~ m/"/ ? 1 : 0); + $text =~ s/\A([^"]*)"/$1``/s if $$quote; + + # keep track of leading and trailing white-space + $lead = ($text =~ /\A(\s*)/s ? $1 : ""); + $trail = ($text =~ /(\s*)\Z/s ? $1 : ""); + + # collapse all white space into a single space + $text =~ s/\s+/ /g; + @words = split(" ", $text); + + # process each word individually + foreach my $word (@words) { + # see if we can infer a link + if ($word =~ /^\w+\(/) { + # has parenthesis so should have been a C<> ref + $word = process_C($word); +# $word =~ /^[^()]*]\(/; +# if (defined $items{$1} && $items{$1}) { +# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$1}#item_" +# . htmlify(0,$word) +# . "\">$word</A></CODE>"; +# } elsif (defined $items{$word} && $items{$word}) { +# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$word}#item_" +# . htmlify(0,$word) +# . "\">$word</A></CODE>"; +# } else { +# $word = "\n<CODE><A HREF=\"#item_" +# . htmlify(0,$word) +# . "\">$word</A></CODE>"; +# } + } elsif ($word =~ /^[\$\@%&*]+\w+$/) { + # perl variables, should be a C<> ref + $word = process_C($word, 1); + } elsif ($word =~ m,^\w+://\w,) { + # looks like a URL + $word = qq(<A HREF="$word">$word</A>); + } elsif ($word =~ /[\w.-]+\@\w+\.\w/) { + # looks like an e-mail address + $word = qq(<A HREF="MAILTO:$word">$word</A>); + } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase? + $word = html_escape($word) if $word =~ /[&<>]/; + $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape; + } else { + $word = html_escape($word) if $word =~ /[&<>]/; + } + } + + # build a new string based upon our conversion + $result = ""; + $rest = join(" ", @words); + while (length($rest) > 75) { + if ( $rest =~ m/^(.{0,75})\s(.*?)$/o || + $rest =~ m/^(\S*)\s(.*?)$/o) { + + $result .= "$1\n"; + $rest = $2; + } else { + $result .= "$rest\n"; + $rest = ""; + } + } + $result .= $rest if $rest; + + # restore the leading and trailing white-space + $result = "$lead$result$trail"; + + return $result; +} + +# +# pre_escape - convert & in text to $amp; +# +sub pre_escape { + my($str) = @_; + + $$str =~ s,&,&,g; +} + +# +# process_L - convert a pod L<> directive to a corresponding HTML link. +# most of the links made are inferred rather than known about directly +# (i.e it's not known whether the =head\d section exists in the target file, +# or whether a .pod file exists in the case of split files). however, the +# guessing usually works. +# +# Unlike the other directives, this should be called with an unprocessed +# string, else tags in the link won't be matched. +# +sub process_L { + my($str) = @_; + my($s1, $s2, $linktext, $page, $section, $link); # work strings + + $str =~ s/\n/ /g; # undo word-wrapped tags + $s1 = $str; + for ($s1) { + # a :: acts like a / + s,::,/,; + + # make sure sections start with a / + s,^",/",g; + s,^,/,g if (!m,/, && / /); + + # check if there's a section specified + if (m,^(.*?)/"?(.*?)"?$,) { # yes + ($page, $section) = ($1, $2); + } else { # no + ($page, $section) = ($str, ""); + } + + # check if we know that this is a section in this page + if (!defined $pages{$page} && defined $sections{$page}) { + $section = $page; + $page = ""; + } + } + + if ($page eq "") { + $link = "#" . htmlify(0,$section); + $linktext = $section; + } elsif (!defined $pages{$page}) { + warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n"; + $link = ""; + $linktext = $page; + } else { + $linktext = ($section ? "$section" : "the $page manpage"); + $section = htmlify(0,$section) if $section ne ""; + + # if there is a directory by the name of the page, then assume that an + # appropriate section will exist in the subdirectory + if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) { + $link = "$htmlroot/$1/$section.html"; + + # since there is no directory by the name of the page, the section will + # have to exist within a .html of the same name. thus, make sure there + # is a .pod or .pm that might become that .html + } else { + $section = "#$section"; + # check if there is a .pod with the page name + if ($pages{$page} =~ /([^:]*)\.pod:/) { + $link = "$htmlroot/$1.html$section"; + } elsif ($pages{$page} =~ /([^:]*)\.pm:/) { + $link = "$htmlroot/$1.html$section"; + } else { + warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ". + "no .pod or .pm found\n"; + $link = ""; + $linktext = $section; + } + } + } + + process_text(\$linktext, 0); + if ($link) { + $s1 = "<A HREF=\"$link\">$linktext</A>"; + } else { + $s1 = "<EM>$linktext</EM>"; + } + return $s1; +} + +# +# process_BFI - process any of the B<>, F<>, or I<> pod-escapes and +# convert them to corresponding HTML directives. +# +sub process_BFI { + my($tag, $str) = @_; + my($s1); # work string + my(%repltext) = ( 'B' => 'STRONG', + 'F' => 'EM', + 'I' => 'EM'); + + # extract the modified text and convert to HTML + $s1 = "<$repltext{$tag}>$str</$repltext{$tag}>"; + return $s1; +} + +# +# process_C - process the C<> pod-escape. +# +sub process_C { + my($str, $doref) = @_; + my($s1, $s2); + + $s1 = $str; + $s1 =~ s/\([^()]*\)//g; # delete parentheses + $s2 = $s1; + $s1 =~ s/\W//g; # delete bogus characters + + # if there was a pod file that we found earlier with an appropriate + # =item directive, then create a link to that page. + if ($doref && defined $items{$s1}) { + $s1 = ($items{$s1} ? + "<A HREF=\"$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) . "\">$str</A>" : + "<A HREF=\"#item_" . htmlify(0,$s2) . "\">$str</A>"); + $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,; + confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/; + } else { + $s1 = "<CODE>$str</CODE>"; + # warn "$0: $podfile: cannot resolve C<$str> in paragraph $paragraph\n" if $verbose + } + + + return $s1; +} + +# +# process_E - process the E<> pod directive which seems to escape a character. +# +sub process_E { + my($str) = @_; + + for ($str) { + s,([^/].*),\&$1\;,g; + } + + return $str; +} + +# +# process_Z - process the Z<> pod directive which really just amounts to +# ignoring it. this allows someone to start a paragraph with an = +# +sub process_Z { + my($str) = @_; + + # there is no equivalent in HTML for this so just ignore it. + $str = ""; + return $str; +} + +# +# process_S - process the S<> pod directive which means to convert all +# spaces in the string to non-breaking spaces (in HTML-eze). +# +sub process_S { + my($str) = @_; + + # convert all spaces in the text to non-breaking spaces in HTML. + $str =~ s/ / /g; + return $str; +} + +# +# process_X - this is supposed to make an index entry. we'll just +# ignore it. +# +sub process_X { + return ''; +} + + +# +# finish_list - finish off any pending HTML lists. this should be called +# after the entire pod file has been read and converted. +# +sub finish_list { + while ($listlevel >= 0) { + print HTML "</DL>\n"; + $listlevel--; + } +} + +# +# htmlify - converts a pod section specification to a suitable section +# specification for HTML. if first arg is 1, only takes 1st word. +# +sub htmlify { + my($compact, $heading) = @_; + + if ($compact) { + $heading =~ /^(\w+)/; + $heading = $1; + } + + # $heading = lc($heading); + $heading =~ s/[^\w\s]/_/g; + $heading =~ s/(\s+)/ /g; + $heading =~ s/^\s*(.*?)\s*$/$1/s; + $heading =~ s/ /_/g; + $heading =~ s/\A(.{32}).*\Z/$1/s; + $heading =~ s/\s+\Z//; + $heading =~ s/_{2,}/_/g; + + return $heading; +} + +BEGIN { +} + +1; + diff --git a/gnu/usr.bin/perl/lib/Tie/RefHash.pm b/gnu/usr.bin/perl/lib/Tie/RefHash.pm new file mode 100644 index 00000000000..66de2572fcd --- /dev/null +++ b/gnu/usr.bin/perl/lib/Tie/RefHash.pm @@ -0,0 +1,123 @@ +package Tie::RefHash; + +=head1 NAME + +Tie::RefHash - use references as hash keys + +=head1 SYNOPSIS + + require 5.004; + use Tie::RefHash; + tie HASHVARIABLE, 'Tie::RefHash', LIST; + + untie HASHVARIABLE; + +=head1 DESCRIPTION + +This module provides the ability to use references as hash keys if +you first C<tie> the hash variable to this module. + +It is implemented using the standard perl TIEHASH interface. Please +see the C<tie> entry in perlfunc(1) and perltie(1) for more information. + +=head1 EXAMPLE + + use Tie::RefHash; + tie %h, 'Tie::RefHash'; + $a = []; + $b = {}; + $c = \*main; + $d = \"gunk"; + $e = sub { 'foo' }; + %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5); + $a->[0] = 'foo'; + $b->{foo} = 'bar'; + for (keys %h) { + print ref($_), "\n"; + } + + +=head1 AUTHOR + +Gurusamy Sarathy gsar@umich.edu + +=head1 VERSION + +Version 1.2 15 Dec 1996 + +=head1 SEE ALSO + +perl(1), perlfunc(1), perltie(1) + +=cut + +require 5.003_11; +use Tie::Hash; +@ISA = qw(Tie::Hash); +use strict; + +sub TIEHASH { + my $c = shift; + my $s = []; + bless $s, $c; + while (@_) { + $s->STORE(shift, shift); + } + return $s; +} + +sub FETCH { + my($s, $k) = @_; + (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k}; +} + +sub STORE { + my($s, $k, $v) = @_; + if (ref $k) { + $s->[0]{"$k"} = [$k, $v]; + } + else { + $s->[1]{$k} = $v; + } + $v; +} + +sub DELETE { + my($s, $k) = @_; + (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k}); +} + +sub EXISTS { + my($s, $k) = @_; + (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k}); +} + +sub FIRSTKEY { + my $s = shift; + my $a = scalar(keys %{$s->[0]}) + scalar(keys %{$s->[1]}); + $s->[2] = 0; + $s->NEXTKEY; +} + +sub NEXTKEY { + my $s = shift; + my ($k, $v); + if (!$s->[2]) { + if (($k, $v) = each %{$s->[0]}) { + return $s->[0]{"$k"}[0]; + } + else { + $s->[2] = 1; + } + } + return each %{$s->[1]}; +} + +sub CLEAR { + my $s = shift; + $s->[2] = 0; + %{$s->[0]} = (); + %{$s->[1]} = (); +} + +1; diff --git a/gnu/usr.bin/perl/lib/Time/gmtime.pm b/gnu/usr.bin/perl/lib/Time/gmtime.pm new file mode 100644 index 00000000000..c1d11d74dbb --- /dev/null +++ b/gnu/usr.bin/perl/lib/Time/gmtime.pm @@ -0,0 +1,88 @@ +package Time::gmtime; +use strict; +use Time::tm; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(gmtime gmctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + $VERSION = 1.01; +} +use vars @EXPORT_OK; + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub gmtime (;$) { populate CORE::gmtime(@_ ? shift : time)} +sub gmctime (;$) { scalar CORE::gmtime(@_ ? shift : time)} + +1; +__END__ + +=head1 NAME + +Time::gmtime - by-name interface to Perl's built-in gmtime() function + +=head1 SYNOPSIS + + use Time::gmtime; + $gm = gmtime(); + printf "The day in Greenwich is %s\n", + (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm->wday() ]; + + use Time::gmtime w(:FIELDS; + printf "The day in Greenwich is %s\n", + (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm_wday() ]; + + $now = gmctime(); + + use Time::gmtime; + use File::stat; + $date_string = gmctime(stat($file)->mtime); + +=head1 DESCRIPTION + +This module's default exports override the core gmtime() function, +replacing it with a version that returns "Time::tm" objects. +This object has methods that return the similarly named structure field +name from the C's tm structure from F<time.h>; namely sec, min, hour, +mday, mon, year, wday, yday, and isdst. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this +still overrides your core functions.) Access these fields as variables +named with a preceding C<tm_> in front their method names. Thus, +C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. + +The gmctime() funtion provides a way of getting at the +scalar sense of the original CORE::gmtime() function. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/Time/localtime.pm b/gnu/usr.bin/perl/lib/Time/localtime.pm new file mode 100644 index 00000000000..94377525973 --- /dev/null +++ b/gnu/usr.bin/perl/lib/Time/localtime.pm @@ -0,0 +1,84 @@ +package Time::localtime; +use strict; +use Time::tm; + +BEGIN { + use Exporter (); + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(localtime ctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + $VERSION = 1.01; +} +use vars @EXPORT_OK; + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)} +sub ctime (;$) { scalar CORE::localtime(@_ ? shift : time) } + +1; + +__END__ + +=head1 NAME + +Time::localtime - by-name interface to Perl's built-in localtime() function + +=head1 SYNOPSIS + + use Time::localtime; + printf "Year is %d\n", localtime->year() + 1900; + + $now = ctime(); + + use Time::localtime; + use File::stat; + $date_string = ctime(stat($file)->mtime); + +=head1 DESCRIPTION + +This module's default exports override the core localtime() function, +replacing it with a version that returns "Time::tm" objects. +This object has methods that return the similarly named structure field +name from the C's tm structure from F<time.h>; namely sec, min, hour, +mday, mon, year, wday, yday, and isdst. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as +variables named with a preceding C<tm_> in front their method names. +Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import +the fields. + +The ctime() funtion provides a way of getting at the +scalar sense of the original CORE::localtime() function. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/Time/tm.pm b/gnu/usr.bin/perl/lib/Time/tm.pm new file mode 100644 index 00000000000..fd47ad19a95 --- /dev/null +++ b/gnu/usr.bin/perl/lib/Time/tm.pm @@ -0,0 +1,31 @@ +package Time::tm; +use strict; + +use Class::Struct qw(struct); +struct('Time::tm' => [ + map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst } +]); + +1; +__END__ + +=head1 NAME + +Time::tm - internal object used by Time::gmtime and Time::localtime + +=head1 SYNOPSIS + +Don't use this module directly. + +=head1 DESCRIPTION + +This module is used internally as a base class by Time::localtime And +Time::gmtime functions. It creates a Time::tm struct object which is +addressable just like's C's tm structure from F<time.h>; namely with sec, +min, hour, mday, mon, year, wday, yday, and isdst. + +This class is an internal interface only. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/UNIVERSAL.pm b/gnu/usr.bin/perl/lib/UNIVERSAL.pm new file mode 100644 index 00000000000..dc02423029e --- /dev/null +++ b/gnu/usr.bin/perl/lib/UNIVERSAL.pm @@ -0,0 +1,97 @@ +package UNIVERSAL; + +# UNIVERSAL should not contain any extra subs/methods beyond those +# that it exists to define. The use of Exporter below is a historical +# accident that should be fixed sometime. +require Exporter; +*import = \&Exporter::import; +@EXPORT_OK = qw(isa can); + +1; +__END__ + +=head1 NAME + +UNIVERSAL - base class for ALL classes (blessed references) + +=head1 SYNOPSIS + + $io = $fd->isa("IO::Handle"); + $sub = $obj->can('print'); + + $yes = UNIVERSAL::isa($ref, "HASH"); + +=head1 DESCRIPTION + +C<UNIVERSAL> is the base class which all bless references will inherit from, +see L<perlobj> + +C<UNIVERSAL> provides the following methods + +=over 4 + +=item isa ( TYPE ) + +C<isa> returns I<true> if C<REF> is blessed into package C<TYPE> +or inherits from package C<TYPE>. + +C<isa> can be called as either a static or object method call. + +=item can ( METHOD ) + +C<can> checks if the object has a method called C<METHOD>. If it does +then a reference to the sub is returned. If it does not then I<undef> +is returned. + +C<can> can be called as either a static or object method call. + +=item VERSION ( [ REQUIRE ] ) + +C<VERSION> will return the value of the variable C<$VERSION> in the +package the object is blessed into. If C<REQUIRE> is given then +it will do a comparison and die if the package version is not +greater than or equal to C<REQUIRE>. + +C<VERSION> can be called as either a static or object method call. + +=back + +The C<isa> and C<can> methods can also be called as subroutines + +=over 4 + +=item UNIVERSAL::isa ( VAL, TYPE ) + +C<isa> returns I<true> if the first argument is a reference and either +of the following statements is true. + +=over 8 + +=item + +C<VAL> is a blessed reference and is blessed into package C<TYPE> +or inherits from package C<TYPE> + +=item + +C<VAL> is a reference to a C<TYPE> of perl variable (er 'HASH') + +=back + +=item UNIVERSAL::can ( VAL, METHOD ) + +If C<VAL> is a blessed reference which has a method called C<METHOD>, +C<can> returns a reference to the subroutine. If C<VAL> is not +a blessed reference, or if it does not have a method C<METHOD>, +I<undef> is returned. + +=back + +These subroutines should I<not> be imported via S<C<use UNIVERSAL qw(...)>>. +If you want simple local access to them you can do + + *isa = \&UNIVERSAL::isa; + +to import isa into your package. + +=cut diff --git a/gnu/usr.bin/perl/lib/User/grent.pm b/gnu/usr.bin/perl/lib/User/grent.pm new file mode 100644 index 00000000000..deb0a8d1be9 --- /dev/null +++ b/gnu/usr.bin/perl/lib/User/grent.pm @@ -0,0 +1,93 @@ +package User::grent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(getgrent getgrgid getgrnam getgr); + @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'User::grent' => [ + name => '$', + passwd => '$', + gid => '$', + members => '@', +]; + +sub populate (@) { + return unless @_; + my $gob = new(); + ($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2]; + @gr_members = @{$gob->[3]} = split ' ', $_[3]; + return $gob; +} + +sub getgrent ( ) { populate(CORE::getgrent()) } +sub getgrnam ($) { populate(CORE::getgrnam(shift)) } +sub getgrgid ($) { populate(CORE::getgrgid(shift)) } +sub getgr ($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam } + +1; +__END__ + +=head1 NAME + +User::grent - by-name interface to Perl's built-in getgr*() functions + +=head1 SYNOPSIS + + use User::grent; + $gr = getgrgid(0) or die "No group zero"; + if ( $gr->name eq 'wheel' && @{$gr->members} > 1 ) { + print "gid zero name wheel, with other members"; + } + + use User::grent qw(:FIELDS; + getgrgid(0) or die "No group zero"; + if ( $gr_name eq 'wheel' && @gr_members > 1 ) { + print "gid zero name wheel, with other members"; + } + + $gr = getgr($whoever); + +=head1 DESCRIPTION + +This module's default exports override the core getgrent(), getgruid(), +and getgrnam() functions, replacing them with versions that return +"User::grent" objects. This object has methods that return the similarly +named structure field name from the C's passwd structure from F<grp.h>; +namely name, passwd, gid, and members (not mem). The first three +return scalars, the last an array reference. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as variables named +with a preceding C<gr_>. Thus, C<$group_obj-E<gt>gid()> corresponds +to $gr_gid if you import the fields. Array references are available as +regular array variables, so C<@{ $group_obj-E<gt>members() }> would be +simply @gr_members. + +The getpw() funtion is a simple front-end that forwards +a numeric argument to getpwuid() and the rest to getpwnam(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/User/pwent.pm b/gnu/usr.bin/perl/lib/User/pwent.pm new file mode 100644 index 00000000000..32301cadfc5 --- /dev/null +++ b/gnu/usr.bin/perl/lib/User/pwent.pm @@ -0,0 +1,103 @@ +package User::pwent; +use strict; + +BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(getpwent getpwuid getpwnam getpw); + @EXPORT_OK = qw( + $pw_name $pw_passwd $pw_uid + $pw_gid $pw_quota $pw_comment + $pw_gecos $pw_dir $pw_shell + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'User::pwent' => [ + name => '$', + passwd => '$', + uid => '$', + gid => '$', + quota => '$', + comment => '$', + gecos => '$', + dir => '$', + shell => '$', +]; + +sub populate (@) { + return unless @_; + my $pwob = new(); + + ( $pw_name, $pw_passwd, $pw_uid, + $pw_gid, $pw_quota, $pw_comment, + $pw_gecos, $pw_dir, $pw_shell, ) = @$pwob = @_; + + return $pwob; +} + +sub getpwent ( ) { populate(CORE::getpwent()) } +sub getpwnam ($) { populate(CORE::getpwnam(shift)) } +sub getpwuid ($) { populate(CORE::getpwuid(shift)) } +sub getpw ($) { ($_[0] =~ /^\d+/) ? &getpwuid : &getpwnam } + +1; +__END__ + +=head1 NAME + +User::pwent - by-name interface to Perl's built-in getpw*() functions + +=head1 SYNOPSIS + + use User::pwent; + $pw = getpwnam('daemon') or die "No daemon user"; + if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?$# ) { + print "gid 1 on root dir"; + } + + use User::pwent qw(:FIELDS); + getpwnam('daemon') or die "No daemon user"; + if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?$# ) { + print "gid 1 on root dir"; + } + + $pw = getpw($whoever); + +=head1 DESCRIPTION + +This module's default exports override the core getpwent(), getpwuid(), +and getpwnam() functions, replacing them with versions that return +"User::pwent" objects. This object has methods that return the similarly +named structure field name from the C's passwd structure from F<pwd.h>; +namely name, passwd, uid, gid, quota, comment, gecos, dir, and shell. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as +variables named with a preceding C<pw_> in front their method names. +Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import +the fields. + +The getpw() funtion is a simple front-end that forwards +a numeric argument to getpwuid() and the rest to getpwnam(). + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/gnu/usr.bin/perl/lib/autouse.pm b/gnu/usr.bin/perl/lib/autouse.pm new file mode 100644 index 00000000000..ab95a19d8ab --- /dev/null +++ b/gnu/usr.bin/perl/lib/autouse.pm @@ -0,0 +1,166 @@ +package autouse; + +#use strict; # debugging only +use 5.003_90; # ->can, for my $var + +$autouse::VERSION = '1.01'; + +$autouse::DEBUG ||= 0; + +sub vet_import ($); + +sub croak { + require Carp; + Carp::croak(@_); +} + +sub import { + my $class = @_ ? shift : 'autouse'; + croak "usage: use $class MODULE [,SUBS...]" unless @_; + my $module = shift; + + (my $pm = $module) =~ s{::}{/}g; + $pm .= '.pm'; + if (exists $INC{$pm}) { + vet_import $module; + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + # $Exporter::Verbose = 1; + return $module->import(map { (my $f = $_) =~ s/\(.*?\)$// } @_); + } + + # It is not loaded: need to do real work. + my $callpkg = caller(0); + print "autouse called from $callpkg\n" if $autouse::DEBUG; + + my $index; + for my $f (@_) { + my $proto; + $proto = $1 if (my $func = $f) =~ s/\((.*)\)$//; + + my $closure_import_func = $func; # Full name + my $closure_func = $func; # Name inside package + my $index = index($func, '::'); + if ($index == -1) { + $closure_import_func = "${callpkg}::$func"; + } else { + $closure_func = substr $func, $index + 2; + croak "autouse into different package attempted" + unless substr($func, 0, $index) eq $module; + } + + my $load_sub = sub { + unless ($INC{$pm}) { + eval {require $pm}; + die if $@; + vet_import $module; + } + *$closure_import_func = \&{"${module}::$closure_func"}; + print "autousing $module; " + ."imported $closure_func as $closure_import_func\n" + if $autouse::DEBUG; + goto &$closure_import_func; + }; + + if (defined $proto) { + *$closure_import_func = eval "sub ($proto) { &\$load_sub }"; + } else { + *$closure_import_func = $load_sub; + } + } +} + +sub vet_import ($) { + my $module = shift; + if (my $import = $module->can('import')) { + croak "autoused module has unique import() method" + unless defined(&Exporter::import) + && $import == \&Exporter::import; + } +} + +1; + +__END__ + +=head1 NAME + +autouse - postpone load of modules until a function is used + +=head1 SYNOPSIS + + use autouse 'Carp' => qw(carp croak); + carp "this carp was predeclared and autoused "; + +=head1 DESCRIPTION + +If the module C<Module> is already loaded, then the declaration + + use autouse 'Module' => qw(func1 func2($;$) Module::func3); + +is equivalent to + + use Module qw(func1 func2); + +if C<Module> defines func2() with prototype C<($;$)>, and func1() and +func3() have no prototypes. (At least if C<Module> uses C<Exporter>'s +C<import>, otherwise it is a fatal error.) + +If the module C<Module> is not loaded yet, then the above declaration +declares functions func1() and func2() in the current package, and +declares a function Module::func3(). When these functions are called, +they load the package C<Module> if needed, and substitute themselves +with the correct definitions. + +=head1 WARNING + +Using C<autouse> will move important steps of your program's execution +from compile time to runtime. This can + +=over + +=item * + +Break the execution of your program if the module you C<autouse>d has +some initialization which it expects to be done early. + +=item * + +hide bugs in your code since important checks (like correctness of +prototypes) is moved from compile time to runtime. In particular, if +the prototype you specified on C<autouse> line is wrong, you will not +find it out until the corresponding function is executed. This will be +very unfortunate for functions which are not always called (note that +for such functions C<autouse>ing gives biggest win, for a workaround +see below). + +=back + +To alleviate the second problem (partially) it is advised to write +your scripts like this: + + use Module; + use autouse Module => qw(carp($) croak(&$)); + carp "this carp was predeclared and autoused "; + +The first line ensures that the errors in your argument specification +are found early. When you ship your application you should comment +out the first line, since it makes the second one useless. + +=head1 BUGS + +If Module::func3() is autoused, and the module is loaded between the +C<autouse> directive and a call to Module::func3(), warnings about +redefinition would appear if warnings are enabled. + +If Module::func3() is autoused, warnings are disabled when loading the +module via autoused functions. + +=head1 AUTHOR + +Ilya Zakharevich (ilya@math.ohio-state.edu) + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/gnu/usr.bin/perl/lib/base.pm b/gnu/usr.bin/perl/lib/base.pm new file mode 100644 index 00000000000..e20a64bc9a4 --- /dev/null +++ b/gnu/usr.bin/perl/lib/base.pm @@ -0,0 +1,49 @@ +=head1 NAME + +base - Establish IS-A relationship with base class at compile time + +=head1 SYNOPSIS + + package Baz; + + use base qw(Foo Bar); + +=head1 DESCRIPTION + +Roughly similar in effect to + + BEGIN { + require Foo; + require Bar; + push @ISA, qw(Foo Bar); + } + +This module was introduced with Perl 5.004_04. + +=head1 BUGS + +Needs proper documentation! + +=cut + +package base; + +sub import { + my $class = shift; + + foreach my $base (@_) { + unless (defined %{"$base\::"}) { + eval "require $base"; + unless (defined %{"$base\::"}) { + require Carp; + Carp::croak("Base class package \"$base\" is empty.\n", + "\t(Perhaps you need to 'use' the module ", + "which defines that package first.)"); + } + } + } + + push @{caller(0) . '::ISA'}, @_; +} + +1; diff --git a/gnu/usr.bin/perl/lib/blib.pm b/gnu/usr.bin/perl/lib/blib.pm new file mode 100644 index 00000000000..9e0f6c07c3d --- /dev/null +++ b/gnu/usr.bin/perl/lib/blib.pm @@ -0,0 +1,71 @@ +package blib; + +=head1 NAME + +blib - Use MakeMaker's uninstalled version of a package + +=head1 SYNOPSIS + + perl -Mblib script [args...] + + perl -Mblib=dir script [args...] + +=head1 DESCRIPTION + +Looks for MakeMaker-like I<'blib'> directory structure starting in +I<dir> (or current directory) and working back up to five levels of '..'. + +Intended for use on command line with B<-M> option as a way of testing +arbitary scripts against an uninstalled version of a package. + +However it is possible to : + + use blib; + or + use blib '..'; + +etc. if you really must. + +=head1 BUGS + +Pollutes global name space for development only task. + +=head1 AUTHOR + +Nick Ing-Simmons nik@tiuk.ti.com + +=cut + +use Cwd; + +use vars qw($VERSION); +$VERSION = '1.00'; + +sub import +{ + my $package = shift; + my $dir = getcwd; + if (@_) + { + $dir = shift; + $dir =~ s/blib$//; + $dir =~ s,/+$,,; + $dir = '.' unless ($dir); + die "$dir is not a directory\n" unless (-d $dir); + } + my $i = 5; + while ($i--) + { + my $blib = "${dir}/blib"; + if (-d $blib && -d "$blib/arch" && -d "$blib/lib") + { + unshift(@INC,"$blib/arch","$blib/lib"); + warn "Using $blib\n"; + return; + } + $dir .= "/.."; + } + die "Cannot find blib even in $dir\n"; +} + +1; diff --git a/gnu/usr.bin/perl/lib/constant.pm b/gnu/usr.bin/perl/lib/constant.pm new file mode 100644 index 00000000000..a0d4f9d5cda --- /dev/null +++ b/gnu/usr.bin/perl/lib/constant.pm @@ -0,0 +1,163 @@ +package constant; + +$VERSION = '1.00'; + +=head1 NAME + +constant - Perl pragma to declare constants + +=head1 SYNOPSIS + + use constant BUFFER_SIZE => 4096; + use constant ONE_YEAR => 365.2425 * 24 * 60 * 60; + use constant PI => 4 * atan2 1, 1; + use constant DEBUGGING => 0; + use constant ORACLE => 'oracle@cs.indiana.edu'; + use constant USERNAME => scalar getpwuid($<); + use constant USERINFO => getpwuid($<); + + sub deg2rad { PI * $_[0] / 180 } + + print "This line does nothing" unless DEBUGGING; + +=head1 DESCRIPTION + +This will declare a symbol to be a constant with the given scalar +or list value. + +When you declare a constant such as C<PI> using the method shown +above, each machine your script runs upon can have as many digits +of accuracy as it can use. Also, your program will be easier to +read, more likely to be maintained (and maintained correctly), and +far less likely to send a space probe to the wrong planet because +nobody noticed the one equation in which you wrote C<3.14195>. + +=head1 NOTES + +The value or values are evaluated in a list context. You may override +this with C<scalar> as shown above. + +These constants do not directly interpolate into double-quotish +strings, although you may do so indirectly. (See L<perlref> for +details about how this works.) + + print "The value of PI is @{[ PI ]}.\n"; + +List constants are returned as lists, not as arrays. + + $homedir = USERINFO[7]; # WRONG + $homedir = (USERINFO)[7]; # Right + +The use of all caps for constant names is merely a convention, +although it is recommended in order to make constants stand out +and to help avoid collisions with other barewords, keywords, and +subroutine names. Constant names must begin with a letter. + +Constant symbols are package scoped (rather than block scoped, as +C<use strict> is). That is, you can refer to a constant from package +Other as C<Other::CONST>. + +As with all C<use> directives, defining a constant happens at +compile time. Thus, it's probably not correct to put a constant +declaration inside of a conditional statement (like C<if ($foo) +{ use constant ... }>). + +Omitting the value for a symbol gives it the value of C<undef> in +a scalar context or the empty list, C<()>, in a list context. This +isn't so nice as it may sound, though, because in this case you +must either quote the symbol name, or use a big arrow, (C<=E<gt>>), +with nothing to point to. It is probably best to declare these +explicitly. + + use constant UNICORNS => (); + use constant LOGFILE => undef; + +The result from evaluating a list constant in a scalar context is +not documented, and is B<not> guaranteed to be any particular value +in the future. In particular, you should not rely upon it being +the number of elements in the list, especially since it is not +B<necessarily> that value in the current implementation. + +Magical values, tied values, and references can be made into +constants at compile time, allowing for way cool stuff like this. +(These error numbers aren't totally portable, alas.) + + use constant E2BIG => ($! = 7); + print E2BIG, "\n"; # something like "Arg list too long" + print 0+E2BIG, "\n"; # "7" + +=head1 TECHNICAL NOTE + +In the current implementation, scalar constants are actually +inlinable subroutines. As of version 5.004 of Perl, the appropriate +scalar constant is inserted directly in place of some subroutine +calls, thereby saving the overhead of a subroutine call. See +L<perlsub/"Constant Functions"> for details about how and when this +happens. + +=head1 BUGS + +In the current version of Perl, list constants are not inlined +and some symbols may be redefined without generating a warning. + +It is not possible to have a subroutine or keyword with the same +name as a constant. This is probably a Good Thing. + +Unlike constants in some languages, these cannot be overridden +on the command line or via environment variables. + +=head1 AUTHOR + +Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from +many other folks. + +=head1 COPYRIGHT + +Copyright (C) 1997, Tom Phoenix + +This module is free software; you can redistribute it or modify it +under the same terms as Perl itself. + +=cut + +use strict; +use Carp; +use vars qw($VERSION); + +#======================================================================= + +# Some of this stuff didn't work in version 5.003, alas. +require 5.003_96; + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + my $name = shift or return; # Ignore 'use constant;' + croak qq{Can't define "$name" as constant} . + qq{ (name contains invalid characters or is empty)} + unless $name =~ /^[^\W_0-9]\w*$/; + + my $pkg = caller; + { + no strict 'refs'; + if (@_ == 1) { + my $scalar = $_[0]; + *{"${pkg}::$name"} = sub () { $scalar }; + } elsif (@_) { + my @list = @_; + *{"${pkg}::$name"} = sub () { @list }; + } else { + *{"${pkg}::$name"} = sub () { }; + } + } + +} + +1; diff --git a/gnu/usr.bin/perl/lib/locale.pm b/gnu/usr.bin/perl/lib/locale.pm new file mode 100644 index 00000000000..48213ab86ce --- /dev/null +++ b/gnu/usr.bin/perl/lib/locale.pm @@ -0,0 +1,33 @@ +package locale; + +=head1 NAME + +locale - Perl pragma to use and avoid POSIX locales for built-in operations + +=head1 SYNOPSIS + + @x = sort @y; # ASCII sorting order + { + use locale; + @x = sort @y; # Locale-defined sorting order + } + @x = sort @y; # ASCII sorting order again + +=head1 DESCRIPTION + +This pragma tells the compiler to enable (or disable) the use of POSIX +locales for built-in operations (LC_CTYPE for regular expressions, and +LC_COLLATE for string comparison). Each "use locale" or "no locale" +affects statements to the end of the enclosing BLOCK. + +=cut + +sub import { + $^H |= 0x800; +} + +sub unimport { + $^H &= ~0x800; +} + +1; diff --git a/gnu/usr.bin/perl/os2/Changes b/gnu/usr.bin/perl/os2/Changes new file mode 100644 index 00000000000..4e0c4d49b53 --- /dev/null +++ b/gnu/usr.bin/perl/os2/Changes @@ -0,0 +1,165 @@ +after 5.003_05: + PERLLIB_PREFIX was not active if it matches an element of @INC + as a whole. + Do not need PERL_SBRK if crtdll-revision is >= 50. + Use -Zsmall-conv if crtdll-revision is >= 50 (in static perl!). +:7: warning: #warning <dirent.h> requires <sys/types.h> + We compile miniperl static. It cannot fork, thus there may be + problems with pipes (since HAS_FORK is in + place). Pipes are required by makemaker. + We compile perl___.exe A.OUT and dynamic. It should be able to + fork. + If we can fork, we my_popen by popen unless "-|". Thus we + write a cooky "-1" into the pid array to indicate + this. + Apparently we can fork, and we can load dynamic extensions + now, though probably not simultaneously. + *DB tests corrected for OS/2 one-user stat[2]. + /bin/sh is intercepted and replaced by SH_PATH. + Note that having '\\' in the command line of one-arg `system' + would trigger call via shell. + Segfault with system {'ls'} 'blah'; corrected. + Documentation of OS/2-different features added to main PODs. + New buitins in Cwd:: + + Cwd::current_drive + Cwd::sys_chdir - leaves drive as it is. + Cwd::change_drive + Cwd::sys_is_absolute - has drive letter and is_rooted + Cwd::sys_is_rooted - has leading [/\\] (maybe + after a drive) + Cwd::sys_is_relative - changes with current dir + Cwd::sys_cwd - Interface to cwd from EMX. + Cwd::sys_abspath(name, dir) + - Really really odious + function. Returns absolute + name of file which would + have 'name' if CWD were 'dir'. + Dir defaults to the current dir. + Cwd::extLibpath [type] - Get/set current value of extended + Cwd::extLibpath_set - library search path. + path [type] + The optional last argument redirects + to END-path if true, + default is to search BEGIN-path. + (Note that some of these may be moved to different + libraries - eventually). + Executables: + perl - can fork, can dynalink (but not simultaneously) + perl_ - can fork, cannot dynalink + perl__ - same as perl___, but PM. + perl___ - cannot fork, can dynalink. + The build of the first one - perl - is rather convoluted, and + requires a build of miniperl_. +after 5.003_05: + PERLLIB_PREFIX was not active if it matches an element of @INC + as a whole. + Do not need PERL_SBRK if crtdll-revision is >= 50. + Use -Zsmall-conv if crtdll-revision is >= 50 (in static perl!). +:7: warning: #warning <dirent.h> requires <sys/types.h> + We compile miniperl static. It cannot fork, thus there may be + problems with pipes (since HAS_FORK is in + place). Pipes are required by makemaker. + We compile perl___.exe A.OUT and dynamic. It should be able to + fork. + If we can fork, we my_popen by popen unless "-|". Thus we + write a cooky "-1" into the pid array to indicate + this. + Apparently we can fork, and we can load dynamic extensions + now, though probably not simultaneously. + *DB tests corrected for OS/2 one-user stat[2]. + /bin/sh is intercepted and replaced by SH_PATH. + Note that having '\\' in the command line of one-arg `system' + would trigger call via shell. + Segfault with system {'ls'} 'blah'; corrected. + Documentation of OS/2-different features added to main PODs. + New buitins in Cwd:: + + Cwd::current_drive + Cwd::sys_chdir - leaves drive as it is. + Cwd::change_drive + Cwd::sys_is_absolute - has drive letter and is_rooted + Cwd::sys_is_rooted - has leading [/\\] (maybe + after a drive) + Cwd::sys_is_relative - changes with current dir + Cwd::sys_cwd - Interface to cwd from EMX. + Cwd::sys_abspath(name, dir) + - Really really odious + function. Returns absolute + name of file which would + have 'name' if CWD were 'dir'. + Dir defaults to the current dir. + Cwd::extLibpath [type] - Get/set current value of extended + Cwd::extLibpath_set - library search path. + path [type] + The optional last argument redirects + to END-path if true, + default is to search BEGIN-path. + (Note that some of these may be moved to different + libraries - eventually). + Executables: + perl - can fork, can dynalink (but not simultaneously) + perl_ - can fork, cannot dynalink + perl__ - same as perl___, but PM. + perl___ - cannot fork, can dynalink. + The build of the first one - perl - is rather convoluted, and + requires a build of miniperl_. + +after 5.003_07: + custom tmpfile and tmpname which may use $TMP, $TEMP. + all the calls to OS/2 API wrapped so that it is safe to use + them under DOS (may die(), though). + Tested that popen works under DOS with modified PDKSH and RSX. + File::Copy works under DOS. + MakeMaker modified to work under DOS (perlmain.c.tmp and sh -c true). + +after 5.003_08: + OS2::PrfDB exports symbols as documented; + should work on OS/2 2.1 again. + uses reliable signals when spawing. + do not use popen() any more - no intermediate shell unless needed. + +after 5.003_11: + Functions emx_{malloc,realloc,calloc,free} are exported from DLL. + get_sysinfo() bugs corrected (flags were not used and wrongly defined). + +after 5.003_20: + _isterm is substituted instead of isatty, s?random instead of srand. + `register' disabled if -DDEBUGGING and not AOUT build: stupid SD386. + 3-argument select() was stomping over memory. + +after 5.003_21: + Can start scripts by executing 'dir/script' and + 'script.sh'. Form without extension will call shell only if + the specified file exists (will not look on path) (to prohibit + trying to run shell commands directly). - Needed by magic.t. + +after 5.003_27: + ALTERNATE_SHEBANG="extproc " supported, thus options on this + line are processed (possibly twice). -S is made legal on such + a line. This -S -x is not needed any more. + perl.dll may be used from non-EMX programs (via PERL_SYS_INIT + - the caller should have valid variable "env" with + environment). Known problems: $$ does not work - is 0, waitpid + returns immediately, thus Perl cannot wait for completion of + started programs. + +after 5.004_01: + flock emulation added (disable by setting env PERL_USE_FLOCK=0), + thanks to Rocco Caputo; + RSX bug with missing waitpid circomvented; + -S bug with full path with \ corrected. + +before 5.004_02: + -S switch to perl enables a search with additional extensions + .cmd, .btm, .bat, .pl as well. This means that if you have + mycmd.pl or mycmd.bat on PATH, + perl -S mycmd + will work. Perl will also look in the current directory first. + Moreover, a bug with \; in PATH being non-separator is fixed. + +after 5.004_03: + $^E tracks calls to CRT now. (May break if Perl masks some + changes to errno?) + $0 may be edited to longer lengths (at least under OS/2). + OS2::REXX->loads looks in the OS/2-ish fashion too. diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/Changes b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Changes new file mode 100644 index 00000000000..55fdc5f6d5c --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension OS2::ExtAttr. + +0.01 Sun Apr 21 11:07:04 1996 + - original version; created by h2xs 1.16 + diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.pm b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.pm new file mode 100644 index 00000000000..bebbcc963e8 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.pm @@ -0,0 +1,186 @@ +package OS2::ExtAttr; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); +# 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( + +); +$VERSION = '0.01'; + +bootstrap OS2::ExtAttr $VERSION; + +# Preloaded methods go here. + +# Format of the array: +# 0 ead, 1 file name, 2 file handle. 3 length, 4 position, 5 need to write. + +sub TIEHASH { + my $class = shift; + my $ea = _create() || die "Cannot create EA: $!"; + my $file = shift; + my ($name, $handle); + if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { + die "File handle is not opened" unless $handle = fileno $file; + _read($ea, undef, $handle, 0); + } else { + $name = $file; + _read($ea, $name, 0, 0); + } + bless [$ea, $name, $handle, 0, 0, 0], $class; +} + +sub DESTROY { + my $eas = shift; + # 0 means: discard eas which are not in $eas->[0]. + _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!" + if $eas->[5]; + _destroy( $eas->[0] ); +} + +sub FIRSTKEY { + my $eas = shift; + $eas->[3] = _count($eas->[0]); + $eas->[4] = 1; + return undef if $eas->[4] > $eas->[3]; + return _get_name($eas->[0], $eas->[4]); +} + +sub NEXTKEY { + my $eas = shift; + $eas->[4]++; + return undef if $eas->[4] > $eas->[3]; + return _get_name($eas->[0], $eas->[4]); +} + +sub FETCH { + my $eas = shift; + my $index = _find($eas->[0], shift); + return undef if $index <= 0; + return value($eas->[0], $index); +} + +sub EXISTS { + my $eas = shift; + return _find($eas->[0], shift) > 0; +} + +sub STORE { + my $eas = shift; + $eas->[5] = 1; + add($eas->[0], shift, shift) > 0 or die "Error setting EA: $!"; +} + +sub DELETE { + my $eas = shift; + my $index = _find($eas->[0], shift); + return undef if $index <= 0; + my $value = value($eas->[0], $index); + _delete($eas->[0], $index) and die "Error deleting EA: $!"; + $eas->[5] = 1; + return $value; +} + +sub CLEAR { + my $eas = shift; + _clear($eas->[0]); + $eas->[5] = 1; +} + +# Here are additional methods: + +*new = \&TIEHASH; + +sub copy { + my $eas = shift; + my $file = shift; + my ($name, $handle); + if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { + die "File handle is not opened" unless $handle = fileno $file; + _write($eas->[0], undef, $handle, 0) or die "Cannot write EA: $!"; + } else { + $name = $file; + _write($eas->[0], $name, 0, 0) or die "Cannot write EA: $!"; + } +} + +sub update { + my $eas = shift; + # 0 means: discard eas which are not in $eas->[0]. + _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!"; +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +OS2::ExtAttr - Perl access to extended attributes. + +=head1 SYNOPSIS + + use OS2::ExtAttr; + tie %ea, 'OS2::ExtAttr', 'my.file'; + print $ea{eaname}; + $ea{myfield} = 'value'; + + untie %ea; + +=head1 DESCRIPTION + +The package provides low-level and high-level interface to Extended +Attributes under OS/2. + +=head2 High-level interface: C<tie> + +The only argument of tie() is a file name, or an open file handle. + +Note that all the changes of the tied hash happen in core, to +propagate it to disk the tied hash should be untie()ed or should go +out of scope. Alternatively, one may use the low-level C<update> +method on the corresponding object. Example: + + tied(%hash)->update; + +Note also that setting/getting EA flag is not supported by the +high-level interface, one should use the low-level interface +instead. To use it on a tied hash one needs undocumented way to find +C<eas> give the tied hash. + +=head2 Low-level interface + +Two low-level methods are supported by the objects: copy() and +update(). The copy() takes one argument: the name of a file to copy +the attributes to, or an opened file handle. update() takes no +arguments, and is discussed above. + +Three convenience functions are provided: + + value($eas, $key) + add($eas, $key, $value [, $flag]) + replace($eas, $key, $value [, $flag]) + +The default value for C<flag> is 0. + +In addition, all the C<_ea_*> and C<_ead_*> functions defined in EMX +library are supported, with leading C<_ea/_ead> stripped. + +=head1 AUTHOR + +Ilya Zakharevich, ilya@math.ohio-state.edu + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.xs b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.xs new file mode 100644 index 00000000000..566b6595c8e --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.xs @@ -0,0 +1,193 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef __cplusplus +} +#endif + +#include "myea.h" + +SV * +my_eadvalue(_ead ead, int index) +{ + SV *sv; + int size = _ead_value_size(ead, index); + void *p; + + if (size == -1) { + die("Error getting size of EA: %s", strerror(errno)); + } + p = _ead_get_value(ead, index); + return newSVpv((char*)p, size); +} + +#define my_eadreplace(ead, index, sv, flag) \ + _ead_replace((ead), (index), flag, SvPVX(sv), SvCUR(sv)) + +#define my_eadadd(ead, name, sv, flag) \ + _ead_add((ead), (name), flag, SvPVX(sv), SvCUR(sv)) + + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = my_ead + +SV * +my_eadvalue(ead, index) + _ead ead + int index + +int +my_eadreplace(ead, index, sv, flag = 0) + _ead ead + int index + SV * sv + int flag + +int +my_eadadd(ead, name, sv, flag = 0) + _ead ead + char * name + SV * sv + int flag + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ea + + +void +_ea_free(ptr) + struct _ea * ptr + +int +_ea_get(dst, path, handle, name) + struct _ea * dst + char * path + int handle + char * name + +int +_ea_put(src, path, handle, name) + struct _ea * src + char * path + int handle + char * name + +int +_ea_remove(path, handle, name) + char * path + int handle + char * name + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ead + +int +_ead_add(ead, name, flags, value, size) + _ead ead + char * name + int flags + void * value + int size + +void +_ead_clear(ead) + _ead ead + +int +_ead_copy(dst_ead, src_ead, src_index) + _ead dst_ead + _ead src_ead + int src_index + +int +_ead_count(ead) + _ead ead + +_ead +_ead_create() + +int +_ead_delete(ead, index) + _ead ead + int index + +void +_ead_destroy(ead) + _ead ead + +int +_ead_fea2list_size(ead) + _ead ead + +void * +_ead_fea2list_to_fealist(src) + void * src + +void * +_ead_fealist_to_fea2list(src) + void * src + +int +_ead_find(ead, name) + _ead ead + char * name + +void * +_ead_get_fea2list(ead) + _ead ead + +int +_ead_get_flags(ead, index) + _ead ead + int index + +char * +_ead_get_name(ead, index) + _ead ead + int index + +void * +_ead_get_value(ead, index) + _ead ead + int index + +int +_ead_name_len(ead, index) + _ead ead + int index + +int +_ead_read(ead, path, handle, flags) + _ead ead + char * path + int handle + int flags + +int +_ead_replace(ead, index, flags, value, size) + _ead ead + int index + int flags + void * value + int size + +void +_ead_sort(ead) + _ead ead + +int +_ead_use_fea2list(ead, src) + _ead ead + void * src + +int +_ead_value_size(ead, index) + _ead ead + int index + +int +_ead_write(ead, path, handle, flags) + _ead ead + char * path + int handle + int flags diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/MANIFEST b/gnu/usr.bin/perl/os2/OS2/ExtAttr/MANIFEST new file mode 100644 index 00000000000..b1a8e80e772 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/MANIFEST @@ -0,0 +1,8 @@ +Changes +ExtAttr.pm +ExtAttr.xs +MANIFEST +Makefile.PL +myea.h +t/os2_ea.t +typemap diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Makefile.PL new file mode 100644 index 00000000000..35680288b8c --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::ExtAttr', + 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION + MAN3PODS => ' ', # Pods will be built by installman. + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/myea.h b/gnu/usr.bin/perl/os2/OS2/ExtAttr/myea.h new file mode 100644 index 00000000000..ec4dc81f993 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/myea.h @@ -0,0 +1,2 @@ +#include <sys/ea.h> +#include <sys/ead.h> diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/t/os2_ea.t b/gnu/usr.bin/perl/os2/OS2/ExtAttr/t/os2_ea.t new file mode 100644 index 00000000000..a1da398d458 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/t/os2_ea.t @@ -0,0 +1,79 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..21\n"; } +END {print "not ok 1\n" unless $loaded;} +use OS2::ExtAttr; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +unlink 't.out' if -f 't.out'; +system 'cmd', '/c', 'echo OK > t.out'; + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 2\n"; + + keys %a == 0 ? print "ok 3\n" : print "not ok 3\n"; + $a{'++'} = '---'; + print "ok 4\n"; + $a{'AAA'} = 'xyz'; + print "ok 5\n"; +} + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 6\n"; + + my $c = keys %a; + $c == 2 ? print "ok 7\n" : print "not ok 7\n# c=$c\n"; + my @b = sort keys %a; + "@b" eq '++ AAA' ? print "ok 8\n" : print "not ok 8\n# keys=`@b'\n"; + $a{'++'} eq '---' ? print "ok 9\n" : print "not ok 9\n";; + $a{'AAA'} eq 'xyz' ? print "ok 10\n" : print "not ok 10\n# aaa->`$a{AAA}'\n"; + $c = delete $a{'++'}; + $c eq '---' ? print "ok 11\n" : print "not ok 11\n# deleted->`$c'\n";; +} + +print "ok 12\n"; + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 13\n"; + + keys %a == 1 ? print "ok 14\n" : print "not ok 14\n"; + my @b = sort keys %a; + "@b" eq 'AAA' ? print "ok 15\n" : print "not ok 15\n"; + $a{'AAA'} eq 'xyz' ? print "ok 16\n" : print "not ok 16\n";; + ! exists $a{'+'} ? print "ok 17\n" : print "not ok 17\n";; + ! defined $a{'+'} ? print "ok 18\n" : print "not ok 18\n# ->`$a{'++'}'\n";; + ! exists $a{'++'} ? print "ok 19\n" : print "not ok 19\n";; + ! defined $a{'++'} ? print "ok 20\n" : print "not ok 20\n# ->`$a{'++'}'\n";; +} + +print "ok 21\n"; +unlink 't.out'; diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/typemap b/gnu/usr.bin/perl/os2/OS2/ExtAttr/typemap new file mode 100644 index 00000000000..a5ff8d63ac3 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/typemap @@ -0,0 +1,2 @@ +struct _ea * T_PTR +_ead T_PTR diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/Changes b/gnu/usr.bin/perl/os2/OS2/PrfDB/Changes new file mode 100644 index 00000000000..3e8bf3f5805 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension OS2::PrfDB. + +0.01 Tue Mar 26 19:35:27 1996 + - original version; created by h2xs 1.16 +0.02: Field do-not-close added to OS2::Prf::Hini. diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/MANIFEST b/gnu/usr.bin/perl/os2/OS2/PrfDB/MANIFEST new file mode 100644 index 00000000000..fb96b03c5d5 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/MANIFEST @@ -0,0 +1,7 @@ +Changes +MANIFEST +Makefile.PL +PrfDB.pm +PrfDB.xs +t/os2_prfdb.t +typemap diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/PrfDB/Makefile.PL new file mode 100644 index 00000000000..39521685dfc --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::PrfDB', + 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION + MAN3PODS => ' ', # Pods will be built by installman. + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.pm b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.pm new file mode 100644 index 00000000000..41d7dba2f1c --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.pm @@ -0,0 +1,314 @@ +package OS2::PrfDB; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); +# 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( + AnyIni UserIni SystemIni + ); +$VERSION = '0.02'; + +bootstrap OS2::PrfDB $VERSION; + +# Preloaded methods go here. + +sub AnyIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(0), + 'Anyone of two "systemish" databases', 1; +} + +sub UserIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(1), 'User settings database', 1; +} + +sub SystemIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(2),'System settings database',1; +} + +use vars qw{$debug @ISA}; +use Tie::Hash; +push @ISA, qw{Tie::Hash}; + +# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator. + +sub TIEHASH { + die "Usage: tie %arr, OS2::PrfDB, filename\n" unless @_ == 2; + my ($obj, $file) = @_; + my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file + : new OS2::PrfDB::Hini $file; + die "Error opening profile database `$file': $!" unless $hini; + # print "tiehash `@_', hini $hini\n" if $debug; + bless [$hini, undef, undef]; +} + +sub STORE { + my ($self, $key, $val) = @_; + die unless @_ == 3; + die unless ref $val eq 'HASH'; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + %sub = %$val; +} + +sub FETCH { + my ($self, $key) = @_; + die unless @_ == 2; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + \%sub; +} + +sub DELETE { + my ($self, $key) = @_; + die unless @_ == 2; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + %sub = (); +} + +# CLEAR ???? - deletion of the whole + +sub EXISTS { + my ($self, $key) = @_; + die unless @_ == 2; + return OS2::Prf::GetLength($self->[0]->[0], $key, undef) >= 0; +} + +sub FIRSTKEY { + my $self = shift; + my $keys = OS2::Prf::Get($self->[0]->[0], undef, undef); + return undef unless defined $keys; + chop($keys); + $self->[1] = [split /\0/, $keys]; + # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; + $self->[2] = 0; + return $self->[1]->[0]; + # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); +} + +sub NEXTKEY { + # print "nextkey `@_'\n" if $debug; + my $self = shift; + return undef unless $self->[2]++ < $#{$self->[1]}; + my $key = $self->[1]->[$self->[2]]; + return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); +} + +package OS2::PrfDB::Hini; + +sub new { + die "Usage: new OS2::PrfDB::Hini filename\n" unless @_ == 2; + shift; + my $file = shift; + my $hini = OS2::Prf::Open($file); + die "Error opening profile database `$file': $!" unless $hini; + bless [$hini, $file]; +} + +# Takes HINI and file name: + +sub new_from_int { shift; bless [@_] } + +# Internal structure 0 => HINI, 1 => filename, 2 => do-not-close. + +sub DESTROY { + my $self = shift; + my $hini = $self->[0]; + unless ($self->[2]) { + OS2::Prf::Close($hini) or die "Error closing profile `$self->[1]': $!"; + } +} + +package OS2::PrfDB::Sub; +use vars qw{$debug @ISA}; +use Tie::Hash; +@ISA = qw{Tie::Hash}; + +# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator, +# 3 => appname. + +sub TIEHASH { + die "Usage: tie %arr, OS2::PrfDB::Sub, filename, appname\n" unless @_ == 3; + my ($obj, $file, $app) = @_; + my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file + : new OS2::PrfDB::Hini $file; + die "Error opening profile database `$file': $!" unless $hini; + # print "tiehash `@_', hini $hini\n" if $debug; + bless [$hini, undef, undef, $app]; +} + +sub STORE { + my ($self, $key, $val) = @_; + die unless @_ == 3; + OS2::Prf::Set($self->[0]->[0], $self->[3], $key, $val); +} + +sub FETCH { + my ($self, $key) = @_; + die unless @_ == 2; + OS2::Prf::Get($self->[0]->[0], $self->[3], $key); +} + +sub DELETE { + my ($self, $key) = @_; + die unless @_ == 2; + OS2::Prf::Set($self->[0]->[0], $self->[3], $key, undef); +} + +# CLEAR ???? - deletion of the whole + +sub EXISTS { + my ($self, $key) = @_; + die unless @_ == 2; + return OS2::Prf::GetLength($self->[0]->[0], $self->[3], $key) >= 0; +} + +sub FIRSTKEY { + my $self = shift; + my $keys = OS2::Prf::Get($self->[0]->[0], $self->[3], undef); + return undef unless defined $keys; + chop($keys); + $self->[1] = [split /\0/, $keys]; + # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; + $self->[2] = 0; + return $self->[1]->[0]; + # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); +} + +sub NEXTKEY { + # print "nextkey `@_'\n" if $debug; + my $self = shift; + return undef unless $self->[2]++ < $#{$self->[1]}; + my $key = $self->[1]->[$self->[2]]; + return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +OS2::PrfDB - Perl extension for access to OS/2 setting database. + +=head1 SYNOPSIS + + use OS2::PrfDB; + tie %settings, OS2::PrfDB, 'my.ini'; + tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; + + print "$settings{firstkey}{subkey}\n"; + print "$subsettings{subkey}\n"; + + tie %system, OS2::PrfDB, SystemIni; + $system{myapp}{mykey} = "myvalue"; + + +=head1 DESCRIPTION + +The extention provides both high-level and low-level access to .ini +files. + +=head2 High level access + +High-level access is the tie-hash access via two packages: +C<OS2::PrfDB> and C<OS2::PrfDB::Sub>. First one supports one argument, +the name of the file to open, the second one the name of the file to +open and so called I<Application name>, or the primary key of the +database. + + tie %settings, OS2::PrfDB, 'my.ini'; + tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; + +One may substitute a handle for already opened ini-file instead of the +file name (obtained via low-level access functions). In particular, 3 +functions SystemIni(), UserIni(), and AnyIni() provide handles to the +"systemish" databases. AniIni will read from both, and write into User +database. + +=head2 Low-level access + +Low-level access functions reside in the package C<OS2::Prf>. They are + +=over 14 + +=item C<Open(file)> + +Opens the database, returns an I<integer handle>. + +=item C<Close(hndl)> + +Closes the database given an I<integer handle>. + +=item C<Get(hndl, appname, key)> + +Retrieves data from the database given 2-part-key C<appname> C<key>. +If C<key> is C<undef>, return the "\0" delimited list of C<key>s, +terminated by \0. If C<appname> is C<undef>, returns the list of +possible C<appname>s in the same form. + +=item C<GetLength(hndl, appname, key)> + +Same as above, but returns the length of the value. + +=item C<Set(hndl, appname, key, value [ , length ])> + +Sets the value. If the C<value> is not defined, removes the C<key>. If +the C<key> is not defined, removes the C<appname>. + +=item C<System(val)> + +Return an I<integer handle> associated with the system database. If +C<val> is 1, it is I<User> database, if 2, I<System> database, if +0, handle for "both" of them: the handle works for read from any one, +and for write into I<User> one. + +=item C<Profiles()> + +returns a reference to a list of two strings, giving names of the +I<User> and I<System> databases. + +=item C<SetUser(file)> + +B<(Not tested.)> Sets the profile name of the I<User> database. The +application should have a message queue to use this function! + +=back + +=head2 Integer handles + +To convert a name or an integer handle into an object acceptable as +argument to tie() interface, one may use the following functions from +the package C<OS2::Prf::Hini>: + +=over 14 + +=item C<new(package, file)> + +=item C<new_from_int(package, int_hndl [ , filename ])> + +=back + +=head2 Exports + +SystemIni(), UserIni(), and AnyIni(). + +=head1 AUTHOR + +Ilya Zakharevich, ilya@math.ohio-state.edu + +=head1 SEE ALSO + +perl(1). + +=cut + diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.xs b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.xs new file mode 100644 index 00000000000..a5b2c89ca6f --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.xs @@ -0,0 +1,131 @@ +#define INCL_WINSHELLDATA /* Or use INCL_WIN, INCL_PM, */ + +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <os2.h> +#ifdef __cplusplus +} +#endif + +#define Prf_Open(pszFileName) SaveWinError(PrfOpenProfile(Perl_hab, (pszFileName))) +#define Prf_Close(hini) (!CheckWinError(PrfCloseProfile(hini))) + +SV * +Prf_Get(HINI hini, PSZ app, PSZ key) { + ULONG len; + BOOL rc; + SV *sv; + + if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return &sv_undef; + sv = newSVpv("", 0); + SvGROW(sv, len); + if (CheckWinError(PrfQueryProfileData(hini, app, key, SvPVX(sv), &len)) + || (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */ + SvREFCNT_dec(sv); + return &sv_undef; + } + SvCUR_set(sv, len); + *SvEND(sv) = 0; + return sv; +} + +U32 +Prf_GetLength(HINI hini, PSZ app, PSZ key) { + U32 len; + + if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return -1; + return len; +} + +#define Prf_Set(hini, app, key, s, l) \ + (!(CheckWinError(PrfWriteProfileData(hini, app, key, s, l)))) + +#define Prf_System(key) \ + ( (key) ? ( (key) == 1 ? HINI_USERPROFILE \ + : ( (key) == 2 ? HINI_SYSTEMPROFILE \ + : (die("Wrong profile id %i", key), 0) )) \ + : HINI_PROFILE) + +SV* +Prf_Profiles() +{ + AV *av = newAV(); + SV *rv; + char user[257]; + char system[257]; + PRFPROFILE info = { 257, user, 257, system}; + + if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return &sv_undef; + if (info.cchUserName > 257 || info.cchSysName > 257) + die("Panic: Profile names too long"); + av_push(av, newSVpv(user, info.cchUserName - 1)); + av_push(av, newSVpv(system, info.cchSysName - 1)); + rv = newRV((SV*)av); + SvREFCNT_dec(av); + return rv; +} + +BOOL +Prf_SetUser(SV *sv) +{ + char user[257]; + char system[257]; + PRFPROFILE info = { 257, user, 257, system}; + + if (!SvPOK(sv)) die("User profile name not defined"); + if (SvCUR(sv) > 256) die("User profile name too long"); + if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return 0; + if (info.cchSysName > 257) + die("Panic: System profile name too long"); + info.cchUserName = SvCUR(sv) + 1; + info.pszUserName = SvPVX(sv); + return !CheckWinError(PrfReset(Perl_hab, &info)); +} + +MODULE = OS2::PrfDB PACKAGE = OS2::Prf PREFIX = Prf_ + +HINI +Prf_Open(pszFileName) + PSZ pszFileName; + +BOOL +Prf_Close(hini) + HINI hini; + +SV * +Prf_Get(hini, app, key) + HINI hini; + PSZ app; + PSZ key; + +int +Prf_Set(hini, app, key, s, l = (SvPOK(ST(3)) ? SvCUR(ST(3)): -1)) + HINI hini; + PSZ app; + PSZ key; + PSZ s; + ULONG l; + +U32 +Prf_GetLength(hini, app, key) + HINI hini; + PSZ app; + PSZ key; + +HINI +Prf_System(key) + int key; + +SV* +Prf_Profiles() + +BOOL +Prf_SetUser(sv) + SV *sv + +BOOT: + Acquire_hab(); diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/t/os2_prfdb.t b/gnu/usr.bin/perl/os2/OS2/PrfDB/t/os2_prfdb.t new file mode 100644 index 00000000000..b9f7d90ae22 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/t/os2_prfdb.t @@ -0,0 +1,190 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)PrfDB\b/) { + print "1..0\n"; + exit 0; + } +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..48\n"; } +END {print "not ok 1\n" unless $loaded;} +use OS2::PrfDB; +$loaded = 1; +use strict; + +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +my $inifile = "my.ini"; + +unlink $inifile if -w $inifile; + +my $ini = OS2::Prf::Open($inifile); +print( ($ini ? "": "not "), "ok 2\n# HINI=`$ini'\n"); + +print( (OS2::Prf::GetLength($ini,'aaa', 'bbb') != -1) ? + "not ok 3\n# err: `$^E'\n" : "ok 3\n"); + + +print( OS2::Prf::Set($ini,'aaa', 'bbb','xyz') ? "ok 4\n" : + "not ok 4\n# err: `$^E'\n"); + +my $len = OS2::Prf::GetLength($ini,'aaa', 'bbb'); +print( $len == 3 ? "ok 5\n" : "not ok 5# len: `$len' err: `$^E'\n"); + +my $val = OS2::Prf::Get($ini,'aaa', 'bbb'); +print( $val eq 'xyz' ? "ok 6\n" : "not ok 6# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini,'aaa', undef); +print( $val eq "bbb\0" ? "ok 7\n" : "not ok 7# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini, undef, undef); +print( $val eq "aaa\0" ? "ok 8\n" : "not ok 8# val: `$val' err: `$^E'\n"); + +my $res = OS2::Prf::Set($ini,'aaa', 'bbb',undef); +print( $res ? "ok 9\n" : "not ok 9# err: `$^E'\n"); + +$val = OS2::Prf::Get($ini, undef, undef); +print( (! defined $val) ? "ok 10\n" : "not ok 10# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini,'aaa', undef); +print( (! defined $val) ? "ok 11\n" : "not ok 11# val: `$val' err: `$^E'\n"); + +print((OS2::Prf::Close($ini) ? "" : "not ") . "ok 12\n"); + +my $files = OS2::Prf::Profiles(); +print( (defined $files) ? "ok 13\n" : "not ok 13# err: `$^E'\n"); +print( (@$files == 2) ? "ok 14\n" : "not ok 14# `@$files' err: `$^E'\n"); +print "# `@$files'\n"; + +$ini = OS2::Prf::Open($inifile); +print( ($ini ? "": "not "), "ok 15\n# HINI=`$ini'\n"); + + +print( OS2::Prf::Set($ini,'aaa', 'ccc','xyz') ? "ok 16\n" : + "not ok 16\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'aaa', 'ddd','123') ? "ok 17\n" : + "not ok 17\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'bbb', 'xxx','abc') ? "ok 18\n" : + "not ok 18\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'bbb', 'yyy','456') ? "ok 19\n" : + "not ok 19\n# err: `$^E'\n"); + +OS2::Prf::Close($ini); + +my %hash1; + +tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; +$OS2::PrfDB::Sub::debug = 1; +print "ok 20\n"; + +my @a1 = keys %hash1; +print (@a1 == 2 ? "ok 21\n" : "not ok 21\n# `@a1'\n"); + +my @a2 = sort @a1; +print ("@a2" eq "ccc ddd" ? "ok 22\n" : "not ok 22\n# `@a2'\n"); + +$val = $hash1{ccc}; +print ($val eq "xyz" ? "ok 23\n" : "not ok 23\n# `$val'\n"); + +$val = $hash1{ddd}; +print ($val eq "123" ? "ok 24\n" : "not ok 24\n# `$val'\n"); + +print (exists $hash1{ccc} ? "ok 25\n" : "not ok 25\n# `$val'\n"); + +print (!exists $hash1{hhh} ? "ok 26\n" : "not ok 26\n# `$val'\n"); + +$hash1{hhh} = 12; +print (exists $hash1{hhh} ? "ok 27\n" : "not ok 27\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 28\n" : "not ok 28\n# `$val'\n"); + +delete $hash1{ccc}; + +untie %hash1; +print "ok 29\n"; + +tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; +print "ok 30\n"; + +@a1 = keys %hash1; +print (@a1 == 2 ? "ok 31\n" : "not ok 31\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "ddd hhh" ? "ok 32\n" : "not ok 32\n# `@a2'\n"); + +print (exists $hash1{hhh} ? "ok 33\n" : "not ok 33\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 34\n" : "not ok 34\n# `$val'\n"); + +%hash1 = (); +print "ok 35\n"; + +%hash1 = ( hhh => 12, ddd => 5); + +untie %hash1; + +my %hash; + +tie %hash, 'OS2::PrfDB', $inifile; +print "ok 36\n"; + +@a1 = keys %hash; +print (@a1 == 2 ? "ok 37\n" : "not ok 37\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "aaa bbb" ? "ok 38\n" : "not ok 38\n# `@a2'\n"); + +print (exists $hash{aaa} ? "ok 39\n" : "not ok 39\n# `$val'\n"); + +$val = $hash{aaa}; +print (ref $val eq "HASH" ? "ok 40\n" : "not ok 40\n# `$val'\n"); + +%hash1 = %$val; +print "ok 41\n"; + +@a1 = keys %hash1; +print (@a1 == 2 ? "ok 42\n" : "not ok 31\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "ddd hhh" ? "ok 43\n" : "not ok 43\n# `@a2'\n"); + +print (exists $hash1{hhh} ? "ok 44\n" : "not ok 44\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 45\n" : "not ok 45\n# `$val'\n"); + +$hash{nnn}{mmm} = 67; +print "ok 46\n"; + +untie %hash; + +my %hash2; + +tie %hash2, 'OS2::PrfDB', $inifile; +print "ok 47\n"; + +print ($hash2{nnn}->{mmm} eq "67" ? "ok 48\n" : "not ok 48\n# `$val'\n"); + +untie %hash2; +unlink $inifile; diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/typemap b/gnu/usr.bin/perl/os2/OS2/PrfDB/typemap new file mode 100644 index 00000000000..0b91f3750a6 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/typemap @@ -0,0 +1,14 @@ +BOOL T_IV +ULONG T_IV +HINI T_IV +HAB T_IV +PSZ T_PVNULL + +############################################################################# +INPUT +T_PVNULL + $var = ( SvOK($arg) ? ($type)SvPV($arg,na) : NULL ) +############################################################################# +OUTPUT +T_PVNULL + sv_setpv((SV*)$arg, $var); diff --git a/gnu/usr.bin/perl/os2/OS2/Process/MANIFEST b/gnu/usr.bin/perl/os2/OS2/Process/MANIFEST new file mode 100644 index 00000000000..0d90d15fca6 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/Process/MANIFEST @@ -0,0 +1,4 @@ +MANIFEST +Makefile.PL +Process.pm +Process.xs diff --git a/gnu/usr.bin/perl/os2/OS2/Process/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/Process/Makefile.PL new file mode 100644 index 00000000000..b7a295f8575 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/Process/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::Process', + 'VERSION' => '0.1', + MAN3PODS => ' ', # Pods will be built by installman. + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/gnu/usr.bin/perl/os2/OS2/Process/Process.pm b/gnu/usr.bin/perl/os2/OS2/Process/Process.pm new file mode 100644 index 00000000000..9216bb1e055 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/Process/Process.pm @@ -0,0 +1,112 @@ +package OS2::Process; + +require Exporter; +require DynaLoader; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); +# 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( + P_BACKGROUND + P_DEBUG + P_DEFAULT + P_DETACH + P_FOREGROUND + P_FULLSCREEN + P_MAXIMIZE + P_MINIMIZE + P_NOCLOSE + P_NOSESSION + P_NOWAIT + P_OVERLAY + P_PM + P_QUOTE + P_SESSION + P_TILDE + P_UNRELATED + P_WAIT + P_WINDOWED +); +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); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined OS2::Process macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap OS2::Process; + +# Preloaded methods go here. + +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +OS2::Process - exports constants for system() call on OS2. + +=head1 SYNOPSIS + + use OS2::Process; + $pid = system(P_PM+P_BACKGROUND, "epm.exe"); + +=head1 DESCRIPTION + +the builtin function system() under OS/2 allows an optional first +argument which denotes the mode of the process. Note that this argument is +recognized only if it is strictly numerical. + +You can use either one of the process modes: + + P_WAIT (0) = wait until child terminates (default) + P_NOWAIT = do not wait until child terminates + P_SESSION = new session + P_DETACH = detached + P_PM = PM program + +and optionally add PM and session option bits: + + P_DEFAULT (0) = default + P_MINIMIZE = minimized + P_MAXIMIZE = maximized + P_FULLSCREEN = fullscreen (session only) + P_WINDOWED = windowed (session only) + + P_FOREGROUND = foreground (if running in foreground) + P_BACKGROUND = background + + P_NOCLOSE = don't close window on exit (session only) + + P_QUOTE = quote all arguments + P_TILDE = MKS argument passing convention + P_UNRELATED = do not kill child when father terminates + +=head1 AUTHOR + +Andreas Kaiser <ak@ananke.s.bawue.de>. + +=head1 SEE ALSO + +C<spawn*>() system calls. + +=cut diff --git a/gnu/usr.bin/perl/os2/OS2/Process/Process.xs b/gnu/usr.bin/perl/os2/OS2/Process/Process.xs new file mode 100644 index 00000000000..bdb2ece7a08 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/Process/Process.xs @@ -0,0 +1,154 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <process.h> + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static unsigned long +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + if (name[0] == 'P' && name[1] == '_') { + if (strEQ(name, "P_BACKGROUND")) +#ifdef P_BACKGROUND + return P_BACKGROUND; +#else + goto not_there; +#endif + if (strEQ(name, "P_DEBUG")) +#ifdef P_DEBUG + return P_DEBUG; +#else + goto not_there; +#endif + if (strEQ(name, "P_DEFAULT")) +#ifdef P_DEFAULT + return P_DEFAULT; +#else + goto not_there; +#endif + if (strEQ(name, "P_DETACH")) +#ifdef P_DETACH + return P_DETACH; +#else + goto not_there; +#endif + if (strEQ(name, "P_FOREGROUND")) +#ifdef P_FOREGROUND + return P_FOREGROUND; +#else + goto not_there; +#endif + if (strEQ(name, "P_FULLSCREEN")) +#ifdef P_FULLSCREEN + return P_FULLSCREEN; +#else + goto not_there; +#endif + if (strEQ(name, "P_MAXIMIZE")) +#ifdef P_MAXIMIZE + return P_MAXIMIZE; +#else + goto not_there; +#endif + if (strEQ(name, "P_MINIMIZE")) +#ifdef P_MINIMIZE + return P_MINIMIZE; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOCLOSE")) +#ifdef P_NOCLOSE + return P_NOCLOSE; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOSESSION")) +#ifdef P_NOSESSION + return P_NOSESSION; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOWAIT")) +#ifdef P_NOWAIT + return P_NOWAIT; +#else + goto not_there; +#endif + if (strEQ(name, "P_OVERLAY")) +#ifdef P_OVERLAY + return P_OVERLAY; +#else + goto not_there; +#endif + if (strEQ(name, "P_PM")) +#ifdef P_PM + return P_PM; +#else + goto not_there; +#endif + if (strEQ(name, "P_QUOTE")) +#ifdef P_QUOTE + return P_QUOTE; +#else + goto not_there; +#endif + if (strEQ(name, "P_SESSION")) +#ifdef P_SESSION + return P_SESSION; +#else + goto not_there; +#endif + if (strEQ(name, "P_TILDE")) +#ifdef P_TILDE + return P_TILDE; +#else + goto not_there; +#endif + if (strEQ(name, "P_UNRELATED")) +#ifdef P_UNRELATED + return P_UNRELATED; +#else + goto not_there; +#endif + if (strEQ(name, "P_WAIT")) +#ifdef P_WAIT + return P_WAIT; +#else + goto not_there; +#endif + if (strEQ(name, "P_WINDOWED")) +#ifdef P_WINDOWED + return P_WINDOWED; +#else + goto not_there; +#endif + } + + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = OS2::Process PACKAGE = OS2::Process + + +unsigned long +constant(name,arg) + char * name + int arg + diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/Changes b/gnu/usr.bin/perl/os2/OS2/REXX/Changes new file mode 100644 index 00000000000..46b38ef46ce --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/Changes @@ -0,0 +1,4 @@ +0.2: + After fixpak17 a lot of other places have mismatched lengths +returned in the REXXPool interface. + Also drop does not work on stems any more. diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/MANIFEST b/gnu/usr.bin/perl/os2/OS2/REXX/MANIFEST new file mode 100644 index 00000000000..4ac81492e4a --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/MANIFEST @@ -0,0 +1,14 @@ +Changes +MANIFEST +Makefile.PL +REXX.pm +REXX.xs +t/rx_cmprt.t +t/rx_dllld.t +t/rx_objcall.t +t/rx_sql.test +t/rx_tiesql.test +t/rx_tievar.t +t/rx_tieydb.t +t/rx_varset.t +t/rx_vrexx.t diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/REXX/Makefile.PL new file mode 100644 index 00000000000..0b43a36612e --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'OS2::REXX', + VERSION => '0.21', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes', +); diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/REXX.pm b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.pm new file mode 100644 index 00000000000..4580ede2947 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.pm @@ -0,0 +1,389 @@ +package OS2::REXX; + +use Carp; +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) +@EXPORT = qw(REXX_call REXX_eval REXX_eval_with); +# Other items we are prepared to export if requested +@EXPORT_OK = qw(drop); + +sub AUTOLOAD { + $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/ + or confess("Undefined subroutine &$AUTOLOAD called"); + return undef if $1 eq "DESTROY"; + $_[0]->find($1) + or confess("Can't find entry '$1' to DLL '$_[0]->{File}'"); + goto &$AUTOLOAD; +} + +@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); +%dlls = (); + +bootstrap OS2::REXX; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +# Cannot autoload, the autoloader is used for the REXX functions. + +sub load +{ + confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1; + my ($class, $file, @where) = (@_, @libs); + return $dlls{$file} if $dlls{$file}; + my $handle; + foreach (@where) { + $handle = DynaLoader::dl_load_file("$_/$file.dll"); + last if $handle; + } + $handle = DynaLoader::dl_load_file($file) unless $handle; + return undef unless $handle; + eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');" + . "sub AUTOLOAD {" + . " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;" + . " goto &OS2::REXX::AUTOLOAD;" + . "} 1;" or die "eval package $@"; + return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file"; +} + +sub find +{ + my $self = shift; + my $file = $self->{File}; + my $handle = $self->{Handle}; + my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; + my $queue = $self->{Queue}; + foreach (@_) { + my $name = "OS2::REXX::${file}::$_"; + next if defined(&$name); + my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) + || DynaLoader::dl_find_symbol($handle, $prefix.$_) + or return 0; + eval "package OS2::REXX::$file; sub $_". + "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }". + "1;" + or die "eval sub"; + } + return 1; +} + +sub prefix +{ + my $self = shift; + $self->{Prefix} = shift; +} + +sub queue +{ + my $self = shift; + $self->{Queue} = shift; +} + +sub drop +{ # Supposedly should drop anything with + # the given prefix. Unfortunately a + # loop is needed after fixpack17. +&OS2::REXX::_drop(@_); +} + +sub dropall +{ # Supposedly should drop anything with + # the given prefix. Unfortunately a + # loop is needed after fixpack17. + &OS2::REXX::_drop(@_); # Try to drop them all. + my $name; + for (@_) { + if (/\.$/) { + OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator + while (($name) = OS2::REXX::_next($_)) { + OS2::REXX::_drop($_ . $name); + } + } + } +} + +sub TIESCALAR +{ + my ($obj, $name) = @_; + $name =~ s/^([\w!?]+)/\U$1\E/; + return bless \$name, OS2::REXX::_SCALAR; +} + +sub TIEARRAY +{ + my ($obj, $name) = @_; + $name =~ s/^([\w!?]+)/\U$1\E/; + return bless [$name, 0], OS2::REXX::_ARRAY; +} + +sub TIEHASH +{ + my ($obj, $name) = @_; + $name =~ s/^([\w!?]+)/\U$1\E/; + return bless {Stem => $name}, OS2::REXX::_HASH; +} + +############################################################################# +package OS2::REXX::_SCALAR; + +sub FETCH +{ + return OS2::REXX::_fetch(${$_[0]}); +} + +sub STORE +{ + return OS2::REXX::_set(${$_[0]}, $_[1]); +} + +sub DESTROY +{ + return OS2::REXX::_drop(${$_[0]}); +} + +############################################################################# +package OS2::REXX::_ARRAY; + +sub FETCH +{ + $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; + return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1])); +} + +sub STORE +{ + $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; + return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]); +} + +############################################################################# +package OS2::REXX::_HASH; + +require Tie::Hash; +@ISA = ('Tie::Hash'); + +sub FIRSTKEY +{ + my ($self) = @_; + my $stem = $self->{Stem}; + + delete $self->{List} if exists $self->{List}; + + my @list = (); + my ($name, $value); + OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator + while (($name) = OS2::REXX::_next($stem)) { + push @list, $name; + } + my $key = pop @list; + + $self->{List} = \@list; + return $key; +} + +sub NEXTKEY +{ + return pop @{$_[0]->{List}}; +} + +sub EXISTS +{ + return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); +} + +sub FETCH +{ + return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); +} + +sub STORE +{ + return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]); +} + +sub DELETE +{ + OS2::REXX::_drop($_[0]->{Stem}.$_[1]); +} + +############################################################################# +package OS2::REXX; + +1; +__END__ + +=head1 NAME + +OS2::REXX - access to DLLs with REXX calling convention and REXX runtime. + +=head2 NOTE + +By default, the REXX variable pool is not available, neither +to Perl, nor to external REXX functions. To enable it, you need to put +your code inside C<REXX_call> function. REXX functions which do not use +variables may be usable even without C<REXX_call> though. + +=head1 SYNOPSIS + + use OS2::REXX; + $ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!"; + @pid = $ydb->RxProcId(); + REXX_call { + tie $s, OS2::REXX, "TEST"; + $s = 1; + }; + +=head1 DESCRIPTION + +=head2 Load REXX DLL + + $dll = load OS2::REXX NAME [, WHERE]; + +NAME is DLL name, without path and extension. + +Directories are searched WHERE first (list of dirs), then environment +paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search +is performed in default DLL path (without adding paths and extensions). + +The DLL is not unloaded when the variable dies. + +Returns DLL object reference, or undef on failure. + +=head2 Define function prefix: + + $dll->prefix(NAME); + +Define the prefix of external functions, prepended to the function +names used within your program, when looking for the entries in the +DLL. + +=head2 Example + + $dll = load OS2::REXX "RexxBase"; + $dll->prefix("RexxBase_"); + $dll->Init(); + +is the same as + + $dll = load OS2::REXX "RexxBase"; + $dll->RexxBase_Init(); + +=head2 Define queue: + + $dll->queue(NAME); + +Define the name of the REXX queue passed to all external +functions of this module. Defaults to "SESSION". + +Check for functions (optional): + + BOOL = $dll->find(NAME [, NAME [, ...]]); + +Returns true if all functions are available. + +=head2 Call external REXX function: + + $dll->function(arguments); + +Returns the return string if the return code is 0, else undef. +Dies with error message if the function is not available. + +=head1 Accessing REXX-runtime + +While calling functions with REXX signature does not require the presence +of the system REXX DLL, there are some actions which require REXX-runtime +present. Among them is the access to REXX variables by name. + +One enables REXX runtime by bracketing your code by + + REXX_call BLOCK; + +(trailing semicolon required!) or + + REXX_call \&subroutine_name; + +Inside such a call one has access to REXX variables (see below), and to + + REXX_eval EXPR; + REXX_eval_with EXPR, + subroutine_name_in_REXX => \&Perl_subroutine + +=head2 Bind scalar variable to REXX variable: + + tie $var, OS2::REXX, "NAME"; + +=head2 Bind array variable to REXX stem variable: + + tie @var, OS2::REXX, "NAME."; + +Only scalar operations work so far. No array assignments, no array +operations, ... FORGET IT. + +=head2 Bind hash array variable to REXX stem variable: + + tie %var, OS2::REXX, "NAME."; + +To access all visible REXX variables via hash array, bind to ""; + +No array assignments. No array operations, other than hash array +operations. Just like the *dbm based implementations. + +For the usual REXX stem variables, append a "." to the name, +as shown above. If the hash key is part of the stem name, for +example if you bind to "", you cannot use lower case in the stem +part of the key and it is subject to character set restrictions. + +=head2 Erase individual REXX variables (bound or not): + + OS2::REXX::drop("NAME" [, "NAME" [, ...]]); + +=head2 Erase REXX variables with given stem (bound or not): + + OS2::REXX::dropall("STEM" [, "STEM" [, ...]]); + +=head1 NOTES + +Note that while function and variable names are case insensitive in the +REXX language, function names exported by a DLL and the REXX variables +(as seen by Perl through the chosen API) are all case sensitive! + +Most REXX DLLs export function names all upper case, but there are a +few which export mixed case names (such as RxExtras). When trying to +find the entry point, both exact case and all upper case are searched. +If the DLL exports "RxNap", you have to specify the exact case, if it +exports "RXOPEN", you can use any case. + +To avoid interfering with subroutine names defined by Perl (DESTROY) +or used within the REXX module (prefix, find), it is best to use mixed +case and to avoid lowercase only or uppercase only names when calling +REXX functions. Be consistent. The same function written in different +ways results in different Perl stubs. + +There is no REXX interpolation on variable names, so the REXX variable +name TEST.ONE is not affected by some other REXX variable ONE. And it +is not the same variable as TEST.one! + +You cannot call REXX functions which are not exported by the DLL. +While most DLLs export all their functions, some, like RxFTP, export +only "...LoadFuncs", which registers the functions within REXX only. + +You cannot call 16-bit DLLs. The few interesting ones I found +(FTP,NETB,APPC) do not export their functions. + +I do not know whether the REXX API is reentrant with respect to +exceptions (signals) when the REXX top-level exception handler is +overridden. So unless you know better than I do, do not access REXX +variables (probably tied to Perl variables) or call REXX functions +which access REXX queues or REXX variables in signal handlers. + +See C<t/rx*.t> for examples. + +=head1 AUTHOR + +Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich +ilya@math.ohio-state.edu. + +=cut diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/REXX.xs b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.xs new file mode 100644 index 00000000000..df7646c42e7 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.xs @@ -0,0 +1,484 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#define INCL_REXXSAA +#include <os2emx.h> + +#if 0 +#define INCL_REXXSAA +#pragma pack(1) +#define _Packed +#include <rexxsaa.h> +#pragma pack() +#endif + +extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, + EXCEPTIONREGISTRATIONRECORD *, + CONTEXTRECORD *, + void *); + +static RXSTRING * strs; +static int nstrs; +static SHVBLOCK * vars; +static int nvars; +static char * trace; + +static RXSTRING rxcommand = { 9, "RXCOMMAND" }; +static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" }; +static RXSTRING rxfunction = { 11, "RXFUNCTION" }; + +static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret); + +#if 1 + #define Set RXSHV_SET + #define Fetch RXSHV_FETCH + #define Drop RXSHV_DROPV +#else + #define Set RXSHV_SYSET + #define Fetch RXSHV_SYFET + #define Drop RXSHV_SYDRO +#endif + +static long incompartment; + +static SV* +exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) +{ + HMODULE hRexx, hRexxAPI; + BYTE buf[200]; + LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, + PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); + APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, + RexxFunctionHandler *); + APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); + RXSTRING args[1]; + RXSTRING inst[2]; + RXSTRING result; + USHORT retcode; + LONG rc; + SV *res; + + if (incompartment) die ("Attempt to reenter into REXX compartment"); + incompartment = 1; + + if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx) + || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI) + || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart) + || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe", + (PFN *)&pRexxRegisterFunctionExe) + || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction", + (PFN *)&pRexxDeregisterFunction)) { + die("REXX not available\n"); + } + + if (handlerName) + pRexxRegisterFunctionExe(handlerName, handler); + + MAKERXSTRING(args[0], NULL, 0); + MAKERXSTRING(inst[0], cmd, strlen(cmd)); + MAKERXSTRING(inst[1], NULL, 0); + MAKERXSTRING(result, NULL, 0); + rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL, + &retcode, &result); + + incompartment = 0; + pRexxDeregisterFunction("StartPerl"); + DosFreeModule(hRexxAPI); + DosFreeModule(hRexx); + if (!RXNULLSTRING(result)) { + res = newSVpv(RXSTRPTR(result), RXSTRLEN(result)); + DosFreeMem(RXSTRPTR(result)); + } else { + res = NEWSV(729,0); + } + if (rc || SvTRUE(GvSV(errgv))) { + if (SvTRUE(GvSV(errgv))) { + die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(errgv), na)) ; + } + die ("REXX compartment returned non-zero status %li", rc); + } + + return res; +} + +static SV* exec_cv; + +static ULONG +PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) +{ + return PERLCALL(NULL, argc, argv, queue, ret); +} + +#define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \ + "StartPerl", PERLSTART) +#define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment()) +#define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \ + exec_in_REXX(cmd,name,PERLSTART)) +#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL) + +static ULONG +PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) +{ + EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; + int i, rc; + unsigned long len; + char *str; + char **arr; + dSP; + + DosSetExceptionHandler(&xreg); + + ENTER; + SAVETMPS; + PUSHMARK(sp); + +#if 0 + if (!my_perl) { + DosUnsetExceptionHandler(&xreg); + return 1; + } +#endif + + if (name) { + int ac = 0; + char **arr = alloca((argc + 1) * sizeof(char *)); + + for (i = 0; i < argc; ++i) + arr[ac++] = argv[i].strptr; + arr[ac] = NULL; + + rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr); + } else if (exec_cv) { + SV *cv = exec_cv; + + exec_cv = NULL; + rc = perl_call_sv(cv, G_SCALAR | G_EVAL); + } else rc = -1; + + SPAGAIN; + + if (rc == 1 && SvOK(TOPs)) { + str = SvPVx(POPs, len); + if (len > 256) + if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) { + DosUnsetExceptionHandler(&xreg); + return 1; + } + memcpy(ret->strptr, str, len); + ret->strlength = len; + } + + PUTBACK ; + FREETMPS ; + LEAVE ; + + if (rc != 1) { + DosUnsetExceptionHandler(&xreg); + return 1; + } + + + DosUnsetExceptionHandler(&xreg); + return 0; +} + +static void +needstrs(int n) +{ + if (n > nstrs) { + if (strs) + free(strs); + nstrs = 2 * n; + strs = malloc(nstrs * sizeof(RXSTRING)); + } +} + +static void +needvars(int n) +{ + if (n > nvars) { + if (vars) + free(vars); + nvars = 2 * n; + vars = malloc(nvars * sizeof(SHVBLOCK)); + } +} + +static void +initialize(void) +{ + needstrs(8); + needvars(8); + trace = getenv("PERL_REXX_DEBUG"); +} + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static int +constant(name, arg) +char *name; +int arg; +{ + errno = EINVAL; + return 0; +} + + +MODULE = OS2::REXX PACKAGE = OS2::REXX + +BOOT: + initialize(); + +int +constant(name,arg) + char * name + int arg + +SV * +_call(name, address, queue="SESSION", ...) + char * name + void * address + char * queue + CODE: + { + ULONG rc; + int argc, i; + RXSTRING result; + UCHAR resbuf[256]; + RexxFunctionHandler *fcn = address; + argc = items-3; + needstrs(argc); + if (trace) + fprintf(stderr, "REXXCALL::_call name: '%s' args:", name); + for (i = 0; i < argc; ++i) { + STRLEN len; + char *ptr = SvPV(ST(3+i), len); + MAKERXSTRING(strs[i], ptr, len); + if (trace) + fprintf(stderr, " '%.*s'", len, ptr); + } + if (!*queue) + queue = "SESSION"; + if (trace) + fprintf(stderr, "\n"); + MAKERXSTRING(result, resbuf, sizeof resbuf); + rc = fcn(name, argc, strs, queue, &result); + if (trace) + fprintf(stderr, " rc=%X, result='%.*s'\n", rc, + result.strlength, result.strptr); + ST(0) = sv_newmortal(); + if (rc == 0) { + if (result.strptr) + sv_setpvn(ST(0), result.strptr, result.strlength); + else + sv_setpvn(ST(0), "", 0); + } + if (result.strptr && result.strptr != resbuf) + DosFreeMem(result.strptr); + } + +int +_set(name,value,...) + char * name + char * value + CODE: + { + int i; + int n = (items + 1) / 2; + ULONG rc; + needvars(n); + if (trace) + fprintf(stderr, "REXXCALL::_set"); + for (i = 0; i < n; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + STRLEN valuelen; + name = SvPV(ST(2*i+0),namelen); + if (2*i+1 < items) { + value = SvPV(ST(2*i+1),valuelen); + } + else { + value = ""; + valuelen = 0; + } + var->shvcode = RXSHV_SET; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = valuelen; + MAKERXSTRING(var->shvname, name, namelen); + MAKERXSTRING(var->shvvalue, value, valuelen); + if (trace) + fprintf(stderr, " %.*s='%.*s'", + var->shvname.strlength, var->shvname.strptr, + var->shvvalue.strlength, var->shvvalue.strptr); + } + if (trace) + fprintf(stderr, "\n"); + vars[n-1].shvnext = NULL; + rc = RexxVariablePool(vars); + if (trace) + fprintf(stderr, " rc=%X\n", rc); + RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE; + } + OUTPUT: + RETVAL + +void +_fetch(name, ...) + char * name + PPCODE: + { + int i; + ULONG rc; + EXTEND(sp, items); + needvars(items); + if (trace) + fprintf(stderr, "REXXCALL::_fetch"); + for (i = 0; i < items; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + name = SvPV(ST(i),namelen); + var->shvcode = RXSHV_FETCH; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = 0; + MAKERXSTRING(var->shvname, name, namelen); + MAKERXSTRING(var->shvvalue, NULL, 0); + if (trace) + fprintf(stderr, " '%s'", name); + } + if (trace) + fprintf(stderr, "\n"); + vars[items-1].shvnext = NULL; + rc = RexxVariablePool(vars); + if (!(rc & ~RXSHV_NEWV)) { + for (i = 0; i < items; ++i) { + int namelen; + SHVBLOCK * var = &vars[i]; + /* returned lengths appear to be swapped */ + /* but beware of "future bug fixes" */ + namelen = var->shvvalue.strlength; /* should be */ + if (var->shvvaluelen < var->shvvalue.strlength) + namelen = var->shvvaluelen; /* is */ + if (trace) + fprintf(stderr, " %.*s='%.*s'\n", + var->shvname.strlength, var->shvname.strptr, + namelen, var->shvvalue.strptr); + if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr) + PUSHs(&sv_undef); + else + PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr, + namelen))); + } + } else { + if (trace) + fprintf(stderr, " rc=%X\n", rc); + } + } + +void +_next(stem) + char * stem + PPCODE: + { + SHVBLOCK sv; + BYTE name[4096]; + ULONG rc; + int len = strlen(stem), namelen, valuelen; + if (trace) + fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem); + sv.shvcode = RXSHV_NEXTV; + sv.shvnext = NULL; + MAKERXSTRING(sv.shvvalue, NULL, 0); + do { + sv.shvnamelen = sizeof name; + sv.shvvaluelen = 0; + MAKERXSTRING(sv.shvname, name, sizeof name); + if (sv.shvvalue.strptr) { + DosFreeMem(sv.shvvalue.strptr); + MAKERXSTRING(sv.shvvalue, NULL, 0); + } + rc = RexxVariablePool(&sv); + } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0); + if (!rc) { + EXTEND(sp, 2); + /* returned lengths appear to be swapped */ + /* but beware of "future bug fixes" */ + namelen = sv.shvname.strlength; /* should be */ + if (sv.shvnamelen < sv.shvname.strlength) + namelen = sv.shvnamelen; /* is */ + valuelen = sv.shvvalue.strlength; /* should be */ + if (sv.shvvaluelen < sv.shvvalue.strlength) + valuelen = sv.shvvaluelen; /* is */ + if (trace) + fprintf(stderr, " %.*s='%.*s'\n", + namelen, sv.shvname.strptr, + valuelen, sv.shvvalue.strptr); + PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len))); + if (sv.shvvalue.strptr) { + PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen))); + DosFreeMem(sv.shvvalue.strptr); + } else + PUSHs(&sv_undef); + } else if (rc != RXSHV_LVAR) { + die("Error %i when in _next", rc); + } else { + if (trace) + fprintf(stderr, " rc=%X\n", rc); + } + } + +int +_drop(name,...) + char * name + CODE: + { + int i; + needvars(items); + for (i = 0; i < items; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + name = SvPV(ST(i),namelen); + var->shvcode = RXSHV_DROPV; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = 0; + MAKERXSTRING(var->shvname, name, var->shvnamelen); + MAKERXSTRING(var->shvvalue, NULL, 0); + } + vars[items-1].shvnext = NULL; + RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE; + } + OUTPUT: + RETVAL + +int +_register(name) + char * name + CODE: + RETVAL = RexxRegisterFunctionExe(name, PERLCALL); + OUTPUT: + RETVAL + +SV* +REXX_call(cv) + SV *cv + PROTOTYPE: & + +SV* +REXX_eval(cmd) + char *cmd + +SV* +REXX_eval_with(cmd,name,cv) + char *cmd + char *name + SV *cv diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_cmprt.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_cmprt.t new file mode 100644 index 00000000000..f2113e3aa33 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_cmprt.t @@ -0,0 +1,40 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +$| = 1; # Otherwise data from REXX may come first + +print "1..13\n"; + +$n = 1; +sub do_me { + print "ok $n\n"; + "OK"; +} + +@res = REXX_call(\&do_me); +print "ok 2\n"; +@res == 1 ? print "ok 3\n" : print "not ok 3\n"; +$res[0] eq "OK" ? print "ok 4\n" : print "not ok 4\n# `$res[0]'\n"; + +# Try again +$n = 5; +@res = REXX_call(\&do_me); +print "ok 6\n"; +@res == 1 ? print "ok 7\n" : print "not ok 7\n"; +$res[0] eq "OK" ? print "ok 8\n" : print "not ok 8\n# `$res[0]'\n"; + +REXX_call { print "ok 9\n" }; +REXX_eval 'say "ok 10"'; +# Try again +REXX_eval 'say "ok 11"'; +print "ok 12\n" if REXX_eval("return 2 + 3") eq 5; +REXX_eval_with 'say myfunc()', myfunc => sub {"ok 13"}; diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_dllld.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_dllld.t new file mode 100644 index 00000000000..9d81bf3e56b --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_dllld.t @@ -0,0 +1,36 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +$path = $ENV{LIBPATH} || $ENV{PATH} or die; +foreach $dir (split(';', $path)) { + next unless -f "$dir/YDBAUTIL.DLL"; + $found = "$dir/YDBAUTIL.DLL"; + last; +} +$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n"; + +print "1..5\n"; + +$module = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; +print "ok 1\n"; + +$address = DynaLoader::dl_find_symbol($module, "RXPROCID") + or die "not ok 2\n# find\n"; +print "ok 2\n"; + +$result = OS2::REXX::_call("RxProcId", $address) or die "not ok 3\n# REXX"; +print "ok 3\n"; + +($pid, $ppid, $ssid) = split(/\s+/, $result); +$pid == $$ ? print "ok 4\n" : print "not ok 4\n# pid\n"; +$ssid == 1 ? print "ok 5\n" : print "not ok 5\n# pid\n"; +print "# pid=$pid, ppid=$ppid, ssid=$ssid\n"; diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_objcall.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_objcall.t new file mode 100644 index 00000000000..cb3c52a8b65 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_objcall.t @@ -0,0 +1,33 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +# +# DLL +# +$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; +print "1..5\n", "ok 1\n"; + +# +# function +# +@pid = $ydba->RxProcId(); +@pid == 1 ? print "ok 2\n" : print "not ok 2\n"; +@res = split " ", $pid[0]; +print "ok 3\n" if $res[0] == $$; +@pid = $ydba->RxProcId(); +@res = split " ", $pid[0]; +print "ok 4\n" if $res[0] == $$; +print "# @pid\n"; + +eval { $ydba->nixda(); }; +print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/; + diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_sql.test b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_sql.test new file mode 100644 index 00000000000..602c76dc47d --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_sql.test @@ -0,0 +1,97 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +sub stmt +{ + my ($s) = @_; + $s =~ s/\s*\n\s*/ /g; + $s =~ s/^\s+//; + $s =~ s/\s+$//; + return $s; +} + +sub sqlcode +{ + OS2::REXX::_fetch("SQLCA.SQLCODE"); +} + +sub sqlstate +{ + OS2::REXX::_fetch("SQLCA.SQLSTATE"); +} + +sub sql +{ + my ($stmt) = stmt(@_); + return 0 if OS2::REXX::_call("sqlexec", $sqlexec, "", $stmt); + return sqlcode() >= 0; +} + +sub dbs +{ + my ($stmt) = stmt(@_); + return 0 if OS2::REXX::_call("sqldbs", $sqldbs, "", $stmt); + return sqlcode() >= 0; +} + +sub error +{ + my ($where) = @_; + print "ERROR in $where: sqlcode=", sqlcode(), " sqlstate=", sqlstate(), "\n"; + dbs("GET MESSAGE INTO :MSG LINEWIDTH 75"); + my $msg = OS2::REXX::_fetch("MSG"); + print "\n", $msg; + exit 1; +} + +REXX_call { + + $sqlar = DynaLoader::dl_load_file("h:/sqllib/dll/sqlar.dll") or die "load"; + $sqldbs = DynaLoader::dl_find_symbol($sqlar, "SQLDBS") or die "find sqldbs"; + $sqlexec = DynaLoader::dl_find_symbol($sqlar, "SQLEXEC") or die "find sqlexec"; + + sql(<<) or error("connect"); + CONNECT TO sample IN SHARE MODE + + OS2::REXX::_set("STMT" => stmt(<<)); + SELECT name FROM sysibm.systables + + sql(<<) or error("prepare"); + PREPARE s1 FROM :stmt + + sql(<<) or error("declare"); + DECLARE c1 CURSOR FOR s1 + + sql(<<) or error("open"); + OPEN c1 + + while (1) { + sql(<<) or error("fetch"); + FETCH c1 INTO :name + + last if sqlcode() == 100; + + print "Table name is ", OS2::REXX::_fetch("NAME"), "\n"; + } + + sql(<<) or error("close"); + CLOSE c1 + + sql(<<) or error("rollback"); + ROLLBACK + + sql(<<) or error("disconnect"); + CONNECT RESET + +}; + +exit 0; diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tiesql.test b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tiesql.test new file mode 100644 index 00000000000..c85a1e990b9 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tiesql.test @@ -0,0 +1,86 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +#extproc perl5 -Rx +#! perl + +use REXX; + +$db2 = load REXX "sqlar" or die "load"; +tie $sqlcode, REXX, "SQLCA.SQLCODE"; +tie $sqlstate, REXX, "SQLCA.SQLSTATE"; +tie %rexx, REXX, ""; + +sub stmt +{ + my ($s) = @_; + $s =~ s/\s*\n\s*/ /g; + $s =~ s/^\s+//; + $s =~ s/\s+$//; + return $s; +} + +sub sql +{ + my ($stmt) = stmt(@_); + return 0 if $db2->SqlExec($stmt); + return $sqlcode >= 0; +} + +sub dbs +{ + my ($stmt) = stmt(@_); + return 0 if $db2->SqlDBS($stmt); + return $sqlcode >= 0; +} + +sub error +{ + my ($where) = @_; + print "ERROR in $where: sqlcode=$sqlcode, sqlstate=$sqlstate\n"; + dbs("GET MESSAGE INTO :msg LINEWIDTH 75"); + print "\n", $rexx{'MSG'}; + exit 1; +} + +sql(<<) or error("connect"); + CONNECT TO sample IN SHARE MODE + +$rexx{'STMT'} = stmt(<<); + SELECT name FROM sysibm.systables + +sql(<<) or error("prepare"); + PREPARE s1 FROM :stmt + +sql(<<) or error("declare"); + DECLARE c1 CURSOR FOR s1 + +sql(<<) or error("open"); + OPEN c1 + +while (1) { + sql(<<) or error("fetch"); + FETCH c1 INTO :name + + last if $sqlcode == 100; + + print "Table name is $rexx{'NAME'}\n"; +} + +sql(<<) or error("close"); + CLOSE c1 + +sql(<<) or error("rollback"); + ROLLBACK + +sql(<<) or error("disconnect"); + CONNECT RESET + +exit 0; diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tievar.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tievar.t new file mode 100644 index 00000000000..77f90c2f59f --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tievar.t @@ -0,0 +1,88 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +# +# DLL +# +load OS2::REXX "ydbautil" or die "1..0\n# load\n"; + +print "1..19\n"; + +REXX_call { + print "ok 1\n"; + + # + # scalar + # + tie $s, OS2::REXX, "TEST"; + print "ok 2\n"; + $s = 1; + print "ok 3\n" if $s eq 1; + print "not ok 3\n# `$s'\n" unless $s eq 1; + untie $s; + + # + # hash + # + + tie %all, OS2::REXX, ""; # all REXX vars + print "ok 4\n"; + + sub show { + # show all REXX vars + print "--@_--\n"; + foreach (keys %all) { + $v = $all{$_}; + print "$_ => $v\n"; + } + } + + sub check { + # check all REXX vars + my ($test, @arr) = @_; + my @rx; + foreach $key (sort keys %all) { push @rx, $key, $all{$key} } + if ("@rx" eq "@arr") {print "ok $test\n"} + else { print "not ok $test\n# expect `@arr', got `@rx'\n" } + } + + + tie %h, OS2::REXX, "TEST."; + print "ok 5\n"; + check(6); + + $h{"one"} = 1; + check(7, "TEST.one", 1); + + $h{"two"} = 2; + check(8, "TEST.one", 1, "TEST.two", 2); + + $h{"one"} = ""; + check(9, "TEST.one", "", "TEST.two", 2); + print "ok 10\n" if exists $h{"one"}; + print "ok 11\n" if exists $h{"two"}; + + delete $h{"one"}; + check(12, "TEST.two", 2); + print "ok 13\n" if not exists $h{"one"}; + print "ok 14\n" if exists $h{"two"}; + + OS2::REXX::dropall("TEST."); + print "ok 15\n"; + check(16); + print "ok 17\n" if not exists $h{"one"}; + print "ok 18\n" if not exists $h{"two"}; + + untie %h; + print "ok 19"; + +}; diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tieydb.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tieydb.t new file mode 100644 index 00000000000..30a2dafb620 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tieydb.t @@ -0,0 +1,31 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; +$rx = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; # from RXU17.ZIP +print "1..7\n", "ok 1\n"; + +$rx->prefix("Rx"); # implicit function prefix +print "ok 2\n"; + +REXX_call { + tie @pib, OS2::REXX, "IB.P"; # bind array to REXX stem variable + print "ok 3\n"; + tie %tib, OS2::REXX, "IB.T."; # bind associative array to REXX stem var + print "ok 4\n"; + + $rx->GetInfoBlocks("IB."); # call REXX function + print "ok 5\n"; + defined $pib[6] ? print "ok 6\n" : print "not ok 6\n# pib\n"; + defined $tib{7} && $tib{7} =~ /^\d+$/ ? print "ok 7\n" + : print "not ok 7\n# tib\n"; + print "# Process status is ", unpack("I", $pib[6]), + ", thread ordinal is $tib{7}\n"; +}; diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_varset.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_varset.t new file mode 100644 index 00000000000..166cf536235 --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_varset.t @@ -0,0 +1,39 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +print "1..9\n"; + +REXX_call { + OS2::REXX::_set("X" => sqrt(2)) and print "ok 1\n"; + $x = OS2::REXX::_fetch("X") and print "ok 2\n"; + if (abs($x - sqrt(2)) < 5e-15) { + print "ok 3\n"; + } else { print "not ok 3\n# sqrt(2) = @{[sqrt(2)]} != `$x'\n" } + OS2::REXX::_set("Y" => sqrt(3)) and print "ok 4\n"; + $i = 0; + $n = 4; + while (($name, $value) = OS2::REXX::_next("")) { + $i++; $n++; + if ($i <= 2 and $name eq "Y" ) { + if ($value eq sqrt(3)) { + print "ok $n\n"; + } else { + print "not ok $n\n# `$name' => `$value'\n" ; + } + } elsif ($i <= 2 and $name eq "X") { + print "ok $n\n" if $value eq sqrt(2); + } else { print "not ok 7\n# name `$name', value `$value'\n" } + } + print "ok 7\n" if $i == 2; + OS2::REXX::_drop("X") and print "ok 8\n"; + $x = OS2::REXX::_fetch("X") or print "ok 9\n"; +}; diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_vrexx.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_vrexx.t new file mode 100644 index 00000000000..04ca6636dbf --- /dev/null +++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_vrexx.t @@ -0,0 +1,59 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +$name = "VREXX"; +$path = $ENV{LIBPATH} || $ENV{PATH} or die; +foreach $dir (split(';', $path)) { + next unless -f "$dir/$name.DLL"; + $found = "$dir/$name.DLL"; + print "# found at `$found'\n"; + last; +} +$found or die "1..0\n#Cannot find $name.DLL\n"; + +print "1..10\n"; + +REXX_call { + $vrexx = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; + print "ok 1\n"; + $vinit = DynaLoader::dl_find_symbol($vrexx, "VINIT") or die "find vinit"; + print "ok 2\n"; + $vexit = DynaLoader::dl_find_symbol($vrexx, "VEXIT") or die "find vexit"; + print "ok 3\n"; + $vmsgbox = DynaLoader::dl_find_symbol($vrexx, "VMSGBOX") or die "find vmsgbox"; + print "ok 4\n"; + $vversion= DynaLoader::dl_find_symbol($vrexx, "VGETVERSION") or die "find vgetversion"; + print "ok 5\n"; + + $result = OS2::REXX::_call("VInit", $vinit) or die "VInit"; + print "ok 6\n"; + print "# VInit: $result\n"; + + OS2::REXX::_set("MBOX.0" => 4, + "MBOX.1" => "Perl VREXX Access Test", + "MBOX.2" => "", + "MBOX.3" => "(C) Andreas Kaiser", + "MBOX.4" => "December 1994") + or die "set var"; + print "ok 7\n"; + + $result = OS2::REXX::_call("VGetVersion", $vversion) or die "VMsgBox"; + print "ok 8\n"; + print "# VGetVersion: $result\n"; + + $result = OS2::REXX::_call("VMsgBox", $vmsgbox, "", "Perl", "MBOX", 1) or die "VMsgBox"; + print "ok 9\n"; + print "# VMsgBox: $result\n"; + + OS2::REXX::_call("VExit", $vexit); + print "ok 10\n"; +}; diff --git a/gnu/usr.bin/perl/os2/dl_os2.c b/gnu/usr.bin/perl/os2/dl_os2.c new file mode 100644 index 00000000000..19f36f6aa7f --- /dev/null +++ b/gnu/usr.bin/perl/os2/dl_os2.c @@ -0,0 +1,71 @@ +#include "dlfcn.h" + +#define INCL_BASE +#include <os2.h> + +static ULONG retcode; + +void * +dlopen(char *path, int mode) +{ + HMODULE handle; + char tmp[260], *beg, *dot; + char fail[300]; + ULONG rc; + + if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0) + return (void *)handle; + + retcode = rc; + + /* Not found. Check for non-FAT name and try truncated name. */ + /* Don't know if this helps though... */ + for (beg = dot = path + strlen(path); + beg > path && !strchr(":/\\", *(beg-1)); + beg--) + if (*beg == '.') + dot = beg; + if (dot - beg > 8) { + int n = beg+8-path; + memmove(tmp, path, n); + memmove(tmp+n, dot, strlen(dot)+1); + if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) + return (void *)handle; + } + + return NULL; +} + +void * +dlsym(void *handle, char *symbol) +{ + ULONG rc, type; + PFN addr; + + rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); + if (rc == 0) { + rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); + if (rc == 0 && type == PT_32BIT) + return (void *)addr; + rc = ERROR_CALL_NOT_IMPLEMENTED; + } + retcode = rc; + return NULL; +} + +char * +dlerror(void) +{ + static char buf[300]; + ULONG len; + + if (retcode == 0) + return NULL; + if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len)) + sprintf(buf, "OS/2 system error code %d", retcode); + else + buf[len] = '\0'; + retcode = 0; + return buf; +} + diff --git a/gnu/usr.bin/perl/os2/dlfcn.h b/gnu/usr.bin/perl/os2/dlfcn.h new file mode 100644 index 00000000000..c96f97f82d9 --- /dev/null +++ b/gnu/usr.bin/perl/os2/dlfcn.h @@ -0,0 +1,3 @@ +void *dlopen(char *path, int mode); +void *dlsym(void *handle, char *symbol); +char *dlerror(void); diff --git a/gnu/usr.bin/perl/plan9/aperl b/gnu/usr.bin/perl/plan9/aperl new file mode 100644 index 00000000000..4d032e3c3d7 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/aperl @@ -0,0 +1,7 @@ +#!/bin/rc + +# aperl: +# Executes perl command and alters stderr to produce Acme-friendly error messages +# Created 02-JUL-1996, Luther Huffman, lutherh@stratcom.com + +/bin/perl $* |[2] /bin/perl -pe 's/ line (\d+)/:$1/' >[1=2] diff --git a/gnu/usr.bin/perl/plan9/arpa/inet.h b/gnu/usr.bin/perl/plan9/arpa/inet.h new file mode 100644 index 00000000000..518d517190c --- /dev/null +++ b/gnu/usr.bin/perl/plan9/arpa/inet.h @@ -0,0 +1,7 @@ +/* Declarations which would have been found in <arpa/inet.h> */ +/* On Plan 9, these are found in <netinet/in.h> */ + +/* extern unsigned long inet_addr(const char *); */ +/* extern char *inet_ntoa(struct in_addr); */ + +#include <netinet/in.h> diff --git a/gnu/usr.bin/perl/plan9/buildinfo b/gnu/usr.bin/perl/plan9/buildinfo new file mode 100644 index 00000000000..9ec2c590b97 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/buildinfo @@ -0,0 +1 @@ +p9pvers = 5.004 diff --git a/gnu/usr.bin/perl/plan9/config.plan9 b/gnu/usr.bin/perl/plan9/config.plan9 new file mode 100644 index 00000000000..463c0942fbb --- /dev/null +++ b/gnu/usr.bin/perl/plan9/config.plan9 @@ -0,0 +1,1709 @@ +/* + * This file is mangled by fndvers (and perhaps other scripts) to produce the config.h + * for Plan 9. It was handwritten because the standard configuration scripts were + * written in a shell dialect incomprehensible to Plan 9. + * config.h for Plan 9 + * Version: 5.004 + */ + +/* Configuration time: 21-Oct-1996 15:11 + * Configured by: Luther Huffman, lutherh@stratcom.com + * Target system: Plan 9 + */ + +#ifndef _config_h_ +#define _config_h_ + +/* CAT2: + * This macro catenates 2 tokens together. + */ + +#define CAT2(a,b)a ## b +#define CAT3(a,b,c)a ## b ## c +#define CAT4(a,b,c,d)a ## b ## c ## d +#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e +#define StGiFy(a)# a +#define STRINGIFY(a)StGiFy(a) +#define SCAT2(a,b)StGiFy(a) StGiFy(b) +#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c) +#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) +#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e) + +/* config-start */ + +/* MEM_ALIGNBYTES: + * This symbol contains the number of bytes required to align a + * double. Usual values are 2, 4 and 8. + */ +#if (_P9P_OBJTYPE == 386) || (_P9P_OBJTYPE==power) +# define MEM_ALIGNBYTES 4 /* config-skip */ +#else +# if _P9P_OBJTYPE == 68020 +# define MEM_ALIGNBYTES 2 /* config-skip */ +# else +# define MEM_ALIGNBYTES 8 /* config-skip */ +# endif +#endif + +/* BIN: + * This symbol holds the path of the bin directory where the package will + * be installed. Program must be prepared to deal with ~name substitution. + */ +/* BIN_EXP: + * This symbol is the filename expanded version of the BIN symbol, for + * programs that do not want to deal with that at run-time. + */ +#define BIN "/_P9P_OBJTYPE/bin" /* */ +#define BIN_EXP "/_P9P_OBJTYPE/bin" /* */ + +/* BINCOMPAT3: + * This symbol, if defined, indicates that Perl 5.004 should be + * binary-compatible with Perl 5.003. + */ +#undef BINCOMPAT3 /**/ + +/* CPPSTDIN: + * This symbol contains the first part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. Typical value of "cc -E" or "/lib/cpp", but it can also + * call a wrapper. See CPPRUN. + */ +/* CPPMINUS: + * This symbol contains the second part of the string which will invoke + * the C preprocessor on the standard input and produce to standard + * output. This symbol will have the value "-" if CPPSTDIN needs a minus + * to specify standard input, otherwise the value is "". + */ +#define CPPSTDIN "cpp" +#define CPPMINUS "" + +/* HAS_ALARM: + * This symbol, if defined, indicates that the alarm routine is + * available. + */ +#define HAS_ALARM /**/ + +/* HASATTRIBUTE: + * This symbol indicates the C compiler can check for function attributes, + * such as printf formats. This is normally only supported by GNU cc. + */ +#undef HASATTRIBUTE /* config-skip*/ +#ifndef HASATTRIBUTE +#define __attribute__(_arg_) +#endif + +/* HAS_BCMP: + * This symbol is defined if the bcmp() routine is available to + * compare blocks of memory. + */ +#define HAS_BCMP /**/ + +/* HAS_BCOPY: + * This symbol is defined if the bcopy() routine is available to + * copy blocks of memory. + */ +#define HAS_BCOPY /**/ + +/* HAS_BZERO: + * This symbol is defined if the bzero() routine is available to + * set a memory block to 0. + */ +#define HAS_BZERO /**/ + +/* CASTI32: + * This symbol is defined if the C compiler can cast negative + * or large floating point numbers to 32-bit ints. + */ +#undef CASTI32 /**/ + +/* CASTNEGFLOAT: + * This symbol is defined if the C compiler can cast negative + * numbers to unsigned longs, ints and shorts. + */ +/* CASTFLAGS: + * This symbol contains flags that say what difficulties the compiler + * has casting odd floating values to unsigned long: + * 0 = ok + * 1 = couldn't cast < 0 + * 2 = couldn't cast >= 0x80000000 + * 4 = couldn't cast in argument expression list + */ +#undef CASTNEGFLOAT /**/ +#if _P9P_OBJTYPE == 386 +# define CASTFLAGS 3 /**/ /* config-skip */ +#else +# define CASTFLAGS 0 /**/ /* config-skip */ +#endif + +/* HAS_CHOWN: + * This symbol, if defined, indicates that the chown routine is + * available. + */ +#undef HAS_CHOWN /**/ + +/* HAS_CHROOT: + * This symbol, if defined, indicates that the chroot routine is + * available. + */ +#undef HAS_CHROOT /**/ + +/* HAS_CHSIZE: + * This symbol, if defined, indicates that the chsize routine is available + * to truncate files. You might need a -lx to get this routine. + */ +#undef HAS_CHSIZE /**/ + +/* VOID_CLOSEDIR: + * This symbol, if defined, indicates that the closedir() routine + * does not return a value. + */ +#define VOID_CLOSEDIR /**/ + +/* HASCONST: + * This symbol, if defined, indicates that this C compiler knows about + * the const type. There is no need to actually test for that symbol + * within your programs. The mere use of the "const" keyword will + * trigger the necessary tests. + */ +#define HASCONST /**/ + +/* HAS_CRYPT: + * This symbol, if defined, indicates that the crypt routine is available + * to encrypt passwords and the like. + */ +/* #define HAS_CRYPT /**/ + +/* HAS_CUSERID: + * This symbol, if defined, indicates that the cuserid routine is + * available to get character login names. + */ +#define HAS_CUSERID /**/ + +/* HAS_DBL_DIG: + * This symbol, if defined, indicates that this system's <float.h> + * or <limits.h> defines the symbol DBL_DIG, which is the number + * of significant digits in a double precision number. If this + * symbol is not defined, a guess of 15 is usually pretty good. + */ +#undef HAS_DBL_DIG /* */ + +/* HAS_DIFFTIME: + * This symbol, if defined, indicates that the difftime routine is + * available. + */ +#define HAS_DIFFTIME /**/ + +/* HAS_DLERROR: + * This symbol, if defined, indicates that the dlerror routine is + * available to return a string describing the last error that + * occurred from a call to dlopen(), dlclose() or dlsym(). + */ +#undef HAS_DLERROR /**/ + +/* HAS_DUP2: + * This symbol, if defined, indicates that the dup2 routine is + * available to duplicate file descriptors. + */ +#define HAS_DUP2 /**/ + +/* HAS_FCHMOD: + * This symbol, if defined, indicates that the fchmod routine is available + * to change mode of opened files. If unavailable, use chmod(). + */ +#undef HAS_FCHMOD /**/ + +/* HAS_FCHOWN: + * This symbol, if defined, indicates that the fchown routine is available + * to change ownership of opened files. If unavailable, use chown(). + */ +#undef HAS_FCHOWN /**/ + +/* HAS_FCNTL: + * This symbol, if defined, indicates to the C program that + * the fcntl() function exists. + */ +#define HAS_FCNTL /**/ + +/* HAS_FGETPOS: + * This symbol, if defined, indicates that the fgetpos routine is + * available to get the file position indicator, similar to ftell(). + */ +#define HAS_FGETPOS /**/ + +/* FLEXFILENAMES: + * This symbol, if defined, indicates that the system supports filenames + * longer than 14 characters. + */ +#define FLEXFILENAMES /**/ + +/* HAS_FLOCK: + * This symbol, if defined, indicates that the flock routine is + * available to do file locking. + */ +#undef HAS_FLOCK /**/ + +/* HAS_FORK: + * This symbol, if defined, indicates that the fork routine is + * available. + */ +#define HAS_FORK /**/ + +/* HAS_FSETPOS: + * This symbol, if defined, indicates that the fsetpos routine is + * available to set the file position indicator, similar to fseek(). + */ +#define HAS_FSETPOS /**/ + +/* HAS_GETGROUPS: + * This symbol, if defined, indicates that the getgroups() routine is + * available to get the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +/* HAS_SETGROUPS: + * This symbol, if defined, indicates that the setgroups() routine is + * available to set the list of process groups. If unavailable, multiple + * groups are probably not supported. + */ +#undef HAS_GETGROUPS /* config-skip */ +#undef HAS_SETGROUPS /* config-skip */ + +/* HAS_GETHOSTENT: + * This symbol, if defined, indicates that the gethostent routine is + * available to lookup host names in some data base or other. + */ +#undef HAS_GETHOSTENT /* config-skip */ + +/* HAS_UNAME: + * This symbol, if defined, indicates that the C program may use the + * uname() routine to derive the host name. See also HAS_GETHOSTNAME + * and PHOSTNAME. + */ +#undef HAS_UNAME /**/ + +/* HAS_GETLOGIN: + * This symbol, if defined, indicates that the getlogin routine is + * available to get the login name. + */ +#define HAS_GETLOGIN /**/ + +/* HAS_GETPGRP: + * This symbol, if defined, indicates that the getpgrp routine is + * available to get the current process group. + */ +/* USE_BSD_GETPGRP: + * This symbol, if defined, indicates that getpgrp needs one + * arguments whereas USG one needs none. + */ +#define HAS_GETPGRP /**/ +#undef USE_BSD_GETPGRP /**/ + +/* HAS_GETPGRP2: + * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX) + * routine is available to get the current process group. + */ +#undef HAS_GETPGRP2 /**/ + +/* HAS_GETPPID: + * This symbol, if defined, indicates that the getppid routine is + * available to get the parent process ID. + */ +#define HAS_GETPPID /**/ + +/* HAS_GETPRIORITY: + * This symbol, if defined, indicates that the getpriority routine is + * available to get a process's priority. + */ +#undef HAS_GETPRIORITY /**/ + +/* HAS_GETTIMEOFDAY: + * This symbol, if defined, indicates that the gettimeofday() system + * call is available for a sub-second accuracy clock. Usually, the file + * <sys/resource.h> needs to be included (see I_SYS_RESOURCE). + * The type "Timeval" should be used to refer to "struct timeval". + */ +#define HAS_GETTIMEOFDAY /**/ +#define Timeval struct timeval /* Structure used by gettimeofday() */ /* config-skip */ + +/* HAS_HTONL: + * This symbol, if defined, indicates that the htonl() routine (and + * friends htons() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_HTONS: + * This symbol, if defined, indicates that the htons() routine (and + * friends htonl() ntohl() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHL: + * This symbol, if defined, indicates that the ntohl() routine (and + * friends htonl() htons() ntohs()) are available to do network + * order byte swapping. + */ +/* HAS_NTOHS: + * This symbol, if defined, indicates that the ntohs() routine (and + * friends htonl() htons() ntohl()) are available to do network + * order byte swapping. + */ +#define HAS_HTONL /**/ + +#define HAS_HTONS /**/ + +#define HAS_NTOHL /**/ + +#define HAS_NTOHS /**/ + +/* HAS_INET_ATON: + * This symbol, if defined, indicates to the C program that the + * inet_aton() function is available to parse IP address "dotted-quad" + * strings. + */ +#undef HAS_INET_ATON /**/ + +/* HAS_ISASCII: + * This manifest constant lets the C program know that isascii + * is available. + */ +#undef HAS_ISASCII /**/ + +/* HAS_KILLPG: + * This symbol, if defined, indicates that the killpg routine is available + * to kill process groups. If unavailable, you probably should use kill + * with a negative process number. + */ +#undef HAS_KILLPG /**/ + +/* HAS_LINK: + * This symbol, if defined, indicates that the link routine is + * available to create hard links. + */ +#define HAS_LINK /**/ + +/* HAS_LOCALECONV: + * This symbol, if defined, indicates that the localeconv routine is + * available for numeric and monetary formatting conventions. + */ +#define HAS_LOCALECONV /**/ + +/* HAS_LOCKF: + * This symbol, if defined, indicates that the lockf routine is + * available to do file locking. + */ +#undef HAS_LOCKF /**/ + +/* HAS_LSTAT: + * This symbol, if defined, indicates that the lstat routine is + * available to do file stats on symbolic links. + */ +#define HAS_LSTAT /**/ + +/* HAS_MBLEN: + * This symbol, if defined, indicates that the mblen routine is available + * to find the number of bytes in a multibye character. + */ +#define HAS_MBLEN /**/ + +/* HAS_MBSTOWCS: + * This symbol, if defined, indicates that the mbstowcs routine is + * available to covert a multibyte string into a wide character string. + */ +#define HAS_MBSTOWCS /**/ + +/* HAS_MBTOWC: + * This symbol, if defined, indicates that the mbtowc routine is available + * to covert a multibyte to a wide character. + */ +#define HAS_MBTOWC /**/ + +/* HAS_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * to compare blocks of memory. + */ +#define HAS_MEMCMP /**/ + +/* HAS_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy blocks of memory. + */ +#define HAS_MEMCPY /**/ + +/* HAS_MEMMOVE: + * This symbol, if defined, indicates that the memmove routine is available + * to copy potentially overlapping blocks of memory. This should be used + * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your + * own version. + */ +#define HAS_MEMMOVE /**/ + +/* HAS_MEMSET: + * This symbol, if defined, indicates that the memset routine is available + * to set blocks of memory. + */ +#define HAS_MEMSET /**/ + +/* HAS_MKDIR: + * This symbol, if defined, indicates that the mkdir routine is available + * to create directories. Otherwise you should fork off a new process to + * exec /bin/mkdir. + */ +#define HAS_MKDIR /**/ + +/* HAS_MKFIFO: + * This symbol, if defined, indicates that the mkfifo routine is + * available to create FIFOs. Otherwise, mknod should be able to + * do it for you. However, if mkfifo is there, mknod might require + * super-user privileges which mkfifo will not. + */ +#define HAS_MKFIFO /**/ + +/* HAS_MKTIME: + * This symbol, if defined, indicates that the mktime routine is + * available. + */ +#define HAS_MKTIME /**/ + +/* HAS_MSG: + * This symbol, if defined, indicates that the entire msg*(2) library is + * supported (IPC mechanism based on message queues). + */ +#undef HAS_MSG /**/ + +/* HAS_NICE: + * This symbol, if defined, indicates that the nice routine is + * available. + */ +#undef HAS_NICE /**/ + +/* HAS_OPEN3: + * This manifest constant lets the C program know that the three + * argument form of open(2) is available. + */ +#define HAS_OPEN3 /**/ + +/* HAS_PATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given filename. + */ +/* HAS_FPATHCONF: + * This symbol, if defined, indicates that pathconf() is available + * to determine file-system related limits and options associated + * with a given open file descriptor. + */ +#define HAS_PATHCONF /**/ +#define HAS_FPATHCONF /**/ + +/* HAS_PAUSE: + * This symbol, if defined, indicates that the pause routine is + * available to suspend a process until a signal is received. + */ +#define HAS_PAUSE /**/ + +/* HAS_PIPE: + * This symbol, if defined, indicates that the pipe routine is + * available to create an inter-process channel. + */ +#define HAS_PIPE /**/ + +/* HAS_POLL: + * This symbol, if defined, indicates that the poll routine is + * available to poll active file descriptors. + */ +#undef HAS_POLL /**/ + +/* HAS_READDIR: + * This symbol, if defined, indicates that the readdir routine is + * available to read directory entries. You may have to include + * <dirent.h>. See I_DIRENT. + */ +#define HAS_READDIR /**/ + +/* HAS_SANE_MEMCMP: + * This symbol, if defined, indicates that the memcmp routine is available + * and can be used to compare relative magnitudes of chars with their high + * bits set. If it is not defined, roll your own version. + */ +#define HAS_SANE_MEMCMP /**/ + +/* HAS_SEEKDIR: + * This symbol, if defined, indicates that the seekdir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#undef HAS_SEEKDIR /**/ + +/* HAS_TELLDIR: + * This symbol, if defined, indicates that the telldir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#undef HAS_TELLDIR /**/ + +/* HAS_REWINDDIR: + * This symbol, if defined, indicates that the rewinddir routine is + * available. You may have to include <dirent.h>. See I_DIRENT. + */ +#define HAS_REWINDDIR /**/ + +/* HAS_READLINK: + * This symbol, if defined, indicates that the readlink routine is + * available to read the value of a symbolic link. + */ +#define HAS_READLINK /**/ + +/* HAS_RENAME: + * This symbol, if defined, indicates that the rename routine is available + * to rename files. Otherwise you should do the unlink(), link(), unlink() + * trick. + */ +#define HAS_RENAME /**/ + +/* HAS_RMDIR: + * This symbol, if defined, indicates that the rmdir routine is + * available to remove directories. Otherwise you should fork off a + * new process to exec /bin/rmdir. + */ +#define HAS_RMDIR /**/ + +/* HAS_SAFE_BCOPY: + * This symbol, if defined, indicates that the bcopy routine is available + * to copy potentially overlapping memory blocks. Otherwise you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +#undef HAS_SAFE_BCOPY /**/ + +/* HAS_SAFE_MEMCPY: + * This symbol, if defined, indicates that the memcpy routine is available + * to copy potentially overlapping memory blocks. Otherwise you should + * probably use memmove() or memcpy(). If neither is defined, roll your + * own version. + */ +#undef HAS_SAFE_MEMCPY /**/ + +/* HAS_SELECT: + * This symbol, if defined, indicates that the select routine is + * available to select active file descriptors. If the timeout field + * is used, <sys/time.h> may need to be included. + */ +#define HAS_SELECT /* config-skip */ + +/* HAS_SEM: + * This symbol, if defined, indicates that the entire sem*(2) library is + * supported. + */ +#undef HAS_SEM /**/ + +/* HAS_SETEGID: + * This symbol, if defined, indicates that the setegid routine is available + * to change the effective gid of the current program. + */ +#undef HAS_SETEGID /**/ + +/* HAS_SETEUID: + * This symbol, if defined, indicates that the seteuid routine is available + * to change the effective uid of the current program. + */ +#undef HAS_SETEUID /**/ + +/* HAS_SETLINEBUF: + * This symbol, if defined, indicates that the setlinebuf routine is + * available to change stderr or stdout from block-buffered or unbuffered + * to a line-buffered mode. + */ +#undef HAS_SETLINEBUF /**/ + +/* HAS_SETLOCALE: + * This symbol, if defined, indicates that the setlocale routine is + * available to handle locale-specific ctype implementations. + */ +#define HAS_SETLOCALE /**/ + +/* HAS_SETPGID: + * This symbol, if defined, indicates that the setpgid routine is + * available to set process group ID. + */ +#define HAS_SETPGID /**/ + +/* HAS_SETPGRP: + * This symbol, if defined, indicates that the setpgrp routine is + * available to set the current process group. + */ +/* USE_BSDPGRP: + * This symbol, if defined, indicates that the BSD notion of process + * group is to be used. For instance, you have to say setpgrp(pid, pgrp) + * instead of the USG setpgrp(). + */ +/* USE_BSD_SETPGRP: + * This symbol, if defined, indicates that setpgrp needs two + * arguments whereas USG one needs none. See also HAS_SETPGID + * for a POSIX interface. + */ +#undef HAS_SETPGRP /**/ +#undef USE_BSDPGRP /**/ +#undef USE_BSD_SETPGRP /**/ + +/* HAS_SETPGRP2: + * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX) + * routine is available to set the current process group. + */ +#undef HAS_SETPGRP2 /**/ + +/* HAS_SETPRIORITY: + * This symbol, if defined, indicates that the setpriority routine is + * available to set a process's priority. + */ +#undef HAS_SETPRIORITY /**/ + +/* HAS_SETREGID: + * This symbol, if defined, indicates that the setregid routine is + * available to change the real and effective gid of the current + * process. + */ +/* HAS_SETRESGID: + * This symbol, if defined, indicates that the setresgid routine is + * available to change the real, effective and saved gid of the current + * process. + */ +#undef HAS_SETREGID /**/ +#undef HAS_SETRESGID /**/ + +/* HAS_SETREUID: + * This symbol, if defined, indicates that the setreuid routine is + * available to change the real and effective uid of the current + * process. + */ +/* HAS_SETRESUID: + * This symbol, if defined, indicates that the setresuid routine is + * available to change the real, effective and saved uid of the current + * process. + */ +#undef HAS_SETREUID /**/ +#undef HAS_SETRESUID /**/ + +/* HAS_SETRGID: + * This symbol, if defined, indicates that the setrgid routine is available + * to change the real gid of the current program. + */ +#undef HAS_SETRGID /**/ + +/* HAS_SETRUID: + * This symbol, if defined, indicates that the setruid routine is available + * to change the real uid of the current program. + */ +#undef HAS_SETRUID /**/ + +/* HAS_SETSID: + * This symbol, if defined, indicates that the setsid routine is + * available to set the process group ID. + */ +#define HAS_SETSID /**/ + +/* HAS_SHM: + * This symbol, if defined, indicates that the entire shm*(2) library is + * supported. + */ +#undef HAS_SHM /**/ + +/* Shmat_t: + * This symbol holds the return type of the shmat() system call. + * Usually set to 'void *' or 'char *'. + */ +/* HAS_SHMAT_PROTOTYPE: + * This symbol, if defined, indicates that the sys/shm.h includes + * a prototype for shmat(). Otherwise, it is up to the program to + * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess, + * but not always right so it should be emitted by the program only + * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs. + */ +#undef Shmat_t /* config-skip */ +#undef HAS_SHMAT_PROTOTYPE /**/ + +/* HAS_SIGACTION: + * This symbol, if defined, indicates that Vr4's sigaction() routine + * is available. + */ +#define HAS_SIGACTION /**/ + +/* HAS_SOCKET: + * This symbol, if defined, indicates that the BSD socket interface is + * supported. + */ +/* HAS_SOCKETPAIR: + * This symbol, if defined, indicates that the BSD socketpair() call is + * supported. + */ +#define HAS_SOCKET /**/ +#define HAS_SOCKETPAIR /**/ + +/* HAS_STRTOD: + * This symbol, if defined, indicates that the strtod routine is + * available to provide better numeric string conversion than atof(). + */ +#define HAS_STRTOD /**/ + +/* HAS_STRTOL: + * This symbol, if defined, indicates that the strtol routine is available + * to provide better numeric string conversion than atoi() and friends. + */ +#define HAS_STRTOL /**/ + +/* HAS_STRTOUL: + * This symbol, if defined, indicates that the strtoul routine is + * available to provide conversion of strings to unsigned long. + */ +#define HAS_STRTOUL /**/ + +/* USE_STAT_BLOCKS: + * This symbol is defined if this system has a stat structure declaring + * st_blksize and st_blocks. + */ +#undef USE_STAT_BLOCKS /**/ + +/* USE_STDIO_PTR: + * This symbol is defined if the _ptr and _cnt fields (or similar) + * of the stdio FILE structure can be used to access the stdio buffer + * for a file handle. If this is defined, then the FILE_ptr(fp) + * and FILE_cnt(fp) macros will also be defined and should be used + * to access these fields. + */ +/* USE_STDIO_BASE: + * This symbol is defined if the _base field (or similar) of the + * stdio FILE structure can be used to access the stdio buffer for + * a file handle. If this is defined, then the FILE_base(fp) macro + * will also be defined and should be used to access this field. + * Also, the FILE_bufsiz(fp) macro will be defined and should be used + * to determine the number of bytes in the buffer. USE_STDIO_BASE + * will never be defined unless USE_STDIO_PTR is. + */ +#undef USE_STDIO_PTR /**/ +#undef USE_STDIO_BASE /**/ + +/* FILE_ptr: + * This macro is used to access the _ptr field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_PTR_LVALUE: + * This symbol is defined if the FILE_ptr macro can be used as an + * lvalue. + */ +/* FILE_cnt: + * This macro is used to access the _cnt field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_PTR is defined. + */ +/* STDIO_CNT_LVALUE: + * This symbol is defined if the FILE_cnt macro can be used as an + * lvalue. + */ +#ifdef USE_STDIO_PTR +#define FILE_ptr(fp) ((fp)->_ptr) +#define STDIO_PTR_LVALUE /**/ +#define FILE_cnt(fp) ((fp)->_cnt) +#define STDIO_CNT_LVALUE /**/ +#endif + +/* FILE_base: + * This macro is used to access the _base field (or equivalent) of the + * FILE structure pointed to by its argument. This macro will always be + * defined if USE_STDIO_BASE is defined. + */ +/* FILE_bufsiz: + * This macro is used to determine the number of bytes in the I/O + * buffer pointed to by _base field (or equivalent) of the FILE + * structure pointed to its argument. This macro will always be defined + * if USE_STDIO_BASE is defined. + */ +#ifdef USE_STDIO_BASE +#define FILE_base(fp) ((fp)->_base) +#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base) +#endif + +/* HAS_STRCHR: + * This symbol is defined to indicate that the strchr()/strrchr() + * functions are available for string searching. If not, try the + * index()/rindex() pair. + */ +/* HAS_INDEX: + * This symbol is defined to indicate that the index()/rindex() + * functions are available for string searching. + */ +#define HAS_STRCHR /**/ +#undef HAS_INDEX /**/ + +/* HAS_STRCOLL: + * This symbol, if defined, indicates that the strcoll routine is + * available to compare strings using collating information. + */ +#define HAS_STRCOLL /**/ + +/* USE_STRUCT_COPY: + * This symbol, if defined, indicates that this C compiler knows how + * to copy structures. If undefined, you'll need to use a block copy + * routine of some sort instead. + */ +#define USE_STRUCT_COPY /**/ + +/* HAS_STRERROR: + * This symbol, if defined, indicates that the strerror routine is + * available to translate error numbers to strings. See the writeup + * of Strerror() in this file before you try to define your own. + */ +/* HAS_SYS_ERRLIST: + * This symbol, if defined, indicates that the sys_errlist array is + * available to translate error numbers to strings. The extern int + * sys_nerr gives the size of that table. + */ +/* Strerror: + * This preprocessor symbol is defined as a macro if strerror() is + * not available to translate error numbers to strings but sys_errlist[] + * array is there. + */ +#define HAS_STRERROR /**/ +#define HAS_SYS_ERRLIST /**/ +#define Strerror(e) strerror(e) + +/* HAS_STRXFRM: + * This symbol, if defined, indicates that the strxfrm() routine is + * available to transform strings. + */ +#define HAS_STRXFRM /**/ + +/* HAS_SYMLINK: + * This symbol, if defined, indicates that the symlink routine is available + * to create symbolic links. + */ +#define HAS_SYMLINK /**/ + +/* HAS_SYSCALL: + * This symbol, if defined, indicates that the syscall routine is + * available to call arbitrary system calls. If undefined, that's tough. + */ +#undef HAS_SYSCALL /**/ + +/* HAS_SYSCONF: + * This symbol, if defined, indicates that sysconf() is available + * to determine system related limits and options. + */ +#define HAS_SYSCONF /**/ + +/* HAS_SYSTEM: + * This symbol, if defined, indicates that the system routine is + * available to issue a shell command. + */ +#define HAS_SYSTEM /**/ + +/* HAS_TCGETPGRP: + * This symbol, if defined, indicates that the tcgetpgrp routine is + * available to get foreground process group ID. + */ +#define HAS_TCGETPGRP /**/ + +/* HAS_TCSETPGRP: + * This symbol, if defined, indicates that the tcsetpgrp routine is + * available to set foreground process group ID. + */ +#define HAS_TCSETPGRP /**/ + +/* Time_t: + * This symbol holds the type returned by time(). It can be long, + * or time_t on BSD sites (in which case <sys/types.h> should be + * included). + */ +#define Time_t time_t /* Time type */ + +/* HAS_TIMES: + * This symbol, if defined, indicates that the times() routine exists. + * Note that this became obsolete on some systems (SUNOS), which now + * use getrusage(). It may be necessary to include <sys/times.h>. + */ +#define HAS_TIMES /**/ + +/* HAS_TRUNCATE: + * This symbol, if defined, indicates that the truncate routine is + * available to truncate files. + */ +#undef HAS_TRUNCATE /**/ + +/* HAS_TZNAME: + * This symbol, if defined, indicates that the tzname[] array is + * available to access timezone names. + */ +#define HAS_TZNAME /**/ + +/* HAS_UMASK: + * This symbol, if defined, indicates that the umask routine is + * available to set and get the value of the file creation mask. + */ +#define HAS_UMASK /**/ + +/* HAS_VFORK: + * This symbol, if defined, indicates that vfork() exists. + */ +#undef HAS_VFORK /**/ + +/* Signal_t: + * This symbol's value is either "void" or "int", corresponding to the + * appropriate return type of a signal handler. Thus, you can declare + * a signal handler using "Signal_t (*handler)()", and define the + * handler using "Signal_t handler(sig)". + */ +#define Signal_t void /* Signal handler's return type */ + +/* HASVOLATILE: + * This symbol, if defined, indicates that this C compiler knows about + * the volatile declaration. + */ +#define HASVOLATILE /**/ +#ifndef HASVOLATILE +#define volatile /* config-skip */ +#endif + +/* HAS_VPRINTF: + * This symbol, if defined, indicates that the vprintf routine is available + * to printf with a pointer to an argument list. If unavailable, you + * may need to write your own, probably in terms of _doprnt(). + */ +/* USE_CHAR_VSPRINTF: + * This symbol is defined if this system has vsprintf() returning type + * (char*). The trend seems to be to declare it as "int vsprintf()". It + * is up to the package author to declare vsprintf correctly based on the + * symbol. + */ +#define HAS_VPRINTF /**/ +#define USE_CHAR_VSPRINTF /**/ + +/* HAS_WAIT4: + * This symbol, if defined, indicates that wait4() exists. + */ +#undef HAS_WAIT4 /**/ + +/* HAS_WAITPID: + * This symbol, if defined, indicates that the waitpid routine is + * available to wait for child process. + */ +#undef HAS_WAITPID /**/ + +/* HAS_WCSTOMBS: + * This symbol, if defined, indicates that the wcstombs routine is + * available to convert wide character strings to multibyte strings. + */ +#define HAS_WCSTOMBS /**/ + +/* HAS_WCTOMB: + * This symbol, if defined, indicates that the wctomb routine is available + * to covert a wide character to a multibyte. + */ +#define HAS_WCTOMB /**/ + +/* Fpos_t: + * This symbol holds the type used to declare file positions in libc. + * It can be fpos_t, long, uint, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Fpos_t fpos_t /* File position type */ + +/* Gid_t: + * This symbol holds the return type of getgid() and the type of + * argument to setrgid() and related functions. Typically, + * it is the type of group ids in the kernel. It can be int, ushort, + * uid_t, etc... It may be necessary to include <sys/types.h> to get + * any typedef'ed information. + */ +#define Gid_t gid_t /* config-skip */ + +/* Groups_t: + * This symbol holds the type used for the second argument to + * [gs]etgroups(). Usually, this is the same of gidtype, but + * sometimes it isn't. It can be int, ushort, uid_t, etc... + * It may be necessary to include <sys/types.h> to get any + * typedef'ed information. This is only required if you have + * getgroups() or setgroups(). + */ +#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) +#define Groups_t gid_t /* Type for 2nd arg to [gs]etgroups() */ +#endif + +/* DB_Prefix_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is u_int32_t. + */ +/* DB_Hash_t: + * This symbol contains the type of the prefix structure element + * in the <db.h> header file. In older versions of DB, it was + * int, while in newer ones it is size_t. + */ +#define DB_Hash_t int /**/ +#define DB_Prefix_t int /**/ + +/* I_DIRENT: + * This symbol, if defined, indicates to the C program that it should + * include <dirent.h>. Using this symbol also triggers the definition + * of the Direntry_t define which ends up being 'struct dirent' or + * 'struct direct' depending on the availability of <dirent.h>. + */ +/* DIRNAMLEN: + * This symbol, if defined, indicates to the C program that the length + * of directory entry names is provided by a d_namlen field. Otherwise + * you need to do strlen() on the d_name field. + */ +/* Direntry_t: + * This symbol is set to 'struct direct' or 'struct dirent' depending on + * whether dirent is available or not. You should use this pseudo type to + * portably declare your directory entries. + */ +#define I_DIRENT /**/ +#undef DIRNAMLEN /**/ +#define Direntry_t struct dirent + +/* I_DLFCN: + * This symbol, if defined, indicates that <dlfcn.h> exists and should + * be included. + */ +#undef I_DLFCN /**/ + +/* I_FCNTL: + * This manifest constant tells the C program to include <fcntl.h>. + */ +#define I_FCNTL /**/ + +/* I_FLOAT: + * This symbol, if defined, indicates to the C program that it should + * include <float.h> to get definition of symbols like DBL_MAX or + * DBL_MIN, i.e. machine dependent floating point values. + */ +#define I_FLOAT /**/ + +/* I_GRP: + * This symbol, if defined, indicates to the C program that it should + * include <grp.h>. + */ +#define I_GRP /**/ + +/* I_LIMITS: + * This symbol, if defined, indicates to the C program that it should + * include <limits.h> to get definition of symbols like WORD_BIT or + * LONG_MAX, i.e. machine dependant limitations. + */ +#define I_LIMITS /**/ + +/* I_MATH: + * This symbol, if defined, indicates to the C program that it should + * include <math.h>. + */ +#define I_MATH /**/ + +/* I_MEMORY: + * This symbol, if defined, indicates to the C program that it should + * include <memory.h>. + */ +#undef I_MEMORY /**/ + +/* I_NDBM: + * This symbol, if defined, indicates that <ndbm.h> exists and should + * be included. + */ +#undef I_NDBM /**/ + +/* I_NET_ERRNO: + * This symbol, if defined, indicates that <net/errno.h> exists and + * should be included. + */ +#undef I_NET_ERRNO /* config-skip */ + +/* I_NETINET_IN: + * This symbol, if defined, indicates to the C program that it should + * include <netinet/in.h>. Otherwise, you may try <sys/in.h>. + */ +#define I_NETINET_IN /* config-skip */ + +/* I_PWD: + * This symbol, if defined, indicates to the C program that it should + * include <pwd.h>. + */ +/* PWQUOTA: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_quota. + */ +/* PWAGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_age. + */ +/* PWCHANGE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_change. + */ +/* PWCLASS: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_class. + */ +/* PWEXPIRE: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_expire. + */ +/* PWCOMMENT: + * This symbol, if defined, indicates to the C program that struct passwd + * contains pw_comment. + */ +#define I_PWD /**/ +#undef PWQUOTA /**/ +#undef PWAGE /**/ +#undef PWCHANGE /**/ +#undef PWCLASS /**/ +#undef PWEXPIRE /**/ +#undef PWCOMMENT /**/ + +/* I_STDDEF: + * This symbol, if defined, indicates that <stddef.h> exists and should + * be included. + */ +#define I_STDDEF /**/ + +/* I_STDLIB: + * This symbol, if defined, indicates that <stdlib.h> exists and should + * be included. + */ +#define I_STDLIB /**/ + +/* I_STRING: + * This symbol, if defined, indicates to the C program that it should + * include <string.h> (USG systems) instead of <strings.h> (BSD systems). + */ +#define I_STRING /**/ + +/* I_SYS_DIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/dir.h>. + */ +#undef I_SYS_DIR /**/ + +/* I_SYS_FILE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/file.h> to get definition of R_OK and friends. + */ +#undef I_SYS_FILE /**/ + +/* I_SYS_IOCTL: + * This symbol, if defined, indicates that <sys/ioctl.h> exists and should + * be included. Otherwise, include <sgtty.h> or <termio.h>. + */ +#define I_SYS_IOCTL /**/ + +/* I_SYS_NDIR: + * This symbol, if defined, indicates to the C program that it should + * include <sys/ndir.h>. + */ +#undef I_SYS_NDIR /**/ + +/* I_SYS_PARAM: + * This symbol, if defined, indicates to the C program that it should + * include <sys/param.h>. + */ +#define I_SYS_PARAM /**/ + +/* Plan 9: file position in Plan 9 is <select.h> */ +/* I_SYS_SELECT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/select.h> in order to get definition of struct timeval. + */ +#undef I_SYS_SELECT /**/ + +/* I_SYS_TIMES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/times.h>. + */ +#define I_SYS_TIMES /**/ + +/* I_SYS_TYPES: + * This symbol, if defined, indicates to the C program that it should + * include <sys/types.h>. + */ +#define I_SYS_TYPES /**/ + +/* I_SYS_UN: + * This symbol, if defined, indicates to the C program that it should + * include <sys/un.h> to get UNIX domain socket definitions. + */ +#define I_SYS_UN /**/ + +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * <termio.h> rather than <sgtty.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * <sgtty.h> rather than <termio.h>. There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +#undef I_TERMIO /**/ +#define I_TERMIOS /**/ +#undef I_SGTTY /**/ + +/* Plan 9: P9 has both <time.h> and <sys/time.h> */ +/* I_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <time.h>. + */ +/* I_SYS_TIME: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h>. + */ +/* I_SYS_TIME_KERNEL: + * This symbol, if defined, indicates to the C program that it should + * include <sys/time.h> with KERNEL defined. + */ +#define I_TIME /**/ +#define I_SYS_TIME /**/ +#undef I_SYS_TIME_KERNEL /**/ + +/* I_UNISTD: + * This symbol, if defined, indicates to the C program that it should + * include <unistd.h>. + */ +#define I_UNISTD /**/ + +/* I_UTIME: + * This symbol, if defined, indicates to the C program that it should + * include <utime.h>. + */ +#define I_UTIME /**/ + +/* I_VFORK: + * This symbol, if defined, indicates to the C program that it should + * include vfork.h. + */ +#undef I_VFORK /**/ + +/* Off_t: + * This symbol holds the type used to declare offsets in the kernel. + * It can be int, long, off_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Off_t off_t /* <offset> type */ + +/* Mode_t: + * This symbol holds the type used to declare file modes + * for systems calls. It is usually mode_t, but may be + * int or unsigned short. It may be necessary to include <sys/types.h> + * to get any typedef'ed information. + */ +#define Mode_t mode_t /* file mode parameter for system calls */ + +/* CAN_PROTOTYPE: + * If defined, this macro indicates that the C compiler can handle + * function prototypes. + */ +/* _: + * 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 _((int argc, char *argv[])); + */ +#define CAN_PROTOTYPE /**/ +#ifdef CAN_PROTOTYPE +#define _(args) args /* config-skip */ +#else +#define _(args) () /* config-skip */ +#endif + +/* RANDBITS: + * This symbol contains the number of bits of random number the rand() + * function produces. Usual values are 15, 16, and 31. + */ +#define RANDBITS 15 /**/ + +/* Select_fd_set_t: + * This symbol holds the type used for the 2nd, 3rd, and 4th + * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET + * is defined, and 'int *' otherwise. This is only useful if you + * have select(), of course. + */ +#define Select_fd_set_t fd_set * /**/ + +/* Size_t: + * This symbol holds the type used to declare length parameters + * for string functions. It is usually size_t, but may be + * unsigned long, int, etc. It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Size_t size_t /* length paramater for string functions */ + +/* SSize_t: + * This symbol holds the type used by functions that return + * a count of bytes or an error condition. It must be a signed type. + * It is usually ssize_t, but may be long or int, etc. + * It may be necessary to include <sys/types.h> or <unistd.h> + * to get any typedef'ed information. + * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). + */ +#define SSize_t ssize_t /* signed count of bytes */ + +/* STDCHAR: + * This symbol is defined to be the type of char used in stdio.h. + * It has the values "unsigned char" or "char". + */ +#define STDCHAR char /**/ + +/* Uid_t: + * This symbol holds the type used to declare user ids in the kernel. + * It can be int, ushort, uid_t, etc... It may be necessary to include + * <sys/types.h> to get any typedef'ed information. + */ +#define Uid_t uid_t /* UID type */ + +/* PLAN9: + This symbol, if defined, indicates that the program is running under the +* Plan 9 operating system. +*/ +#define PLAN9 /**/ + +#define OSNAME "plan9" + +#define BIN_SH "/bin/rc" /* config-skip */ + +/* MYMALLOC: + * This symbol, if defined, indicates that we're using our own malloc. + */ +#undef MYMALLOC /**/ + + +#undef VMS /* config-skip */ + +/* LOC_SED: + * This symbol holds the complete pathname to the sed program. + */ +#define LOC_SED "/bin/sed" /**/ + +/* ARCHLIB_EXP: + * This symbol contains the ~name expanded version of ARCHLIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define ARCHLIB_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION" +#define ARCHLIB "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION" + +/* ARCHNAME: + * This symbol holds a string representing the architecture name. + * It may be used to construct an architecture-dependant pathname + * where library files may be held under a private library, for + * instance. + */ +#define ARCHNAME "plan9__P9P_OBJTYPE" /**/ + +/* BYTEORDER: + * This symbol hold the hexadecimal constant defined in byteorder, + * i.e. 0x1234 or 0x4321, etc... + */ +#if _P9P_OBJTYPE == 386 +# define BYTEORDER 0x1234 /* little-endian */ /* config-skip */ +#else +# define BYTEORDER 0x4321 /* big-endian */ /* config-skip */ +#endif + +/* CSH: + * This symbol, if defined, indicates that the C-shell exists. + * If defined, contains the full pathname of csh. + */ +#undef CSH /**/ + +/* DLSYM_NEEDS_UNDERSCORE: + * This symbol, if defined, indicates that we need to prepend an + * underscore to the symbol name before calling dlsym(). This only + * makes sense if you *have* dlsym, which we will presume is the + * case if you're using dl_dlopen.xs. + */ +#undef DLSYM_NEEDS_UNDERSCORE /* */ + +/* SETUID_SCRIPTS_ARE_SECURE_NOW: + * This symbol, if defined, indicates that the bug that prevents + * setuid scripts from being secure is not present in this kernel. + */ +/* DOSUID: + * This symbol, if defined, indicates that the C program should + * check the script that it is executing for setuid/setgid bits, and + * attempt to emulate setuid/setgid on systems that have disabled + * setuid #! scripts because the kernel can't do it securely. + * It is up to the package designer to make sure that this emulation + * is done securely. Among other things, it should do an fstat on + * the script it just opened to make sure it really is a setuid/setgid + * script, it should make sure the arguments passed correspond exactly + * to the argument on the #! line, and it should not trust any + * subprocesses to which it must pass the filename rather than the + * file descriptor of the script to be executed. + */ +#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/ +#undef DOSUID /**/ + +/* Gconvert: + * This preprocessor macro is defined to convert a floating point + * number to a string without a trailing decimal point. This + * emulates the behavior of sprintf("%g"), but is sometimes much more + * efficient. If gconvert() is not available, but gcvt() drops the + * trailing decimal point, then gcvt() is used. If all else fails, + * a macro using sprintf("%g") is used. Arguments for the Gconvert + * macro are: value, number of digits, whether trailing zeros should + * be retained, and the output buffer. + * Possible values are: + * d_Gconvert='gconvert((x),(n),(t),(b))' + * d_Gconvert='gcvt((x),(n),(b))' + * d_Gconvert='sprintf((b),"%.*g",(n),(x))' + * The last two assume trailing zeros should not be kept. + */ +#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x)) + +/* Sigjmp_buf: + * This is the buffer type to be used with Sigsetjmp and Siglongjmp. + */ +/* Sigsetjmp: + * This macro is used in the same way as sigsetjmp(), but will invoke + * traditional setjmp() if sigsetjmp isn't available. + */ +/* Siglongjmp: + * This macro is used in the same way as siglongjmp(), but will invoke + * traditional longjmp() if siglongjmp isn't available. + */ +#define HAS_SIGSETJMP /**/ /* config-skip */ +#define Sigjmp_buf sigjmp_buf /* config-skip */ +#define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) /* config-skip */ +#define Siglongjmp(buf,retval) siglongjmp(buf,retval) /* config-skip */ + +/* USE_DYNAMIC_LOADING: + * This symbol, if defined, indicates that dynamic loading of + * some sort is available. + */ +#undef USE_DYNAMIC_LOADING /**/ + +/* I_DBM: + * This symbol, if defined, indicates that <dbm.h> exists and should + * be included. + */ +/* I_RPCSVC_DBM: + * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and + * should be included. + */ +#undef I_DBM /**/ +#undef I_RPCSVC_DBM /**/ + +/* I_LOCALE: + * This symbol, if defined, indicates to the C program that it should + * include <locale.h>. + */ +#define I_LOCALE /**/ + +/* I_SYS_STAT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/stat.h>. + */ +#define I_SYS_STAT /**/ + +/* I_STDARG: + * This symbol, if defined, indicates that <stdarg.h> exists and should + * be included. + */ +/* I_VARARGS: + * This symbol, if defined, indicates to the C program that it should + * include <varargs.h>. + */ +#define I_STDARG /**/ +#undef I_VARARGS /**/ + +/* INTSIZE: + * This symbol contains the value of sizeof(int) so that the C + * preprocessor can make decisions based on it. + */ +/* LONGSIZE: + * This symbol contains the value of sizeof(long) so that the C + * preprocessor can make decisions based on it. + */ +/* SHORTSIZE: + * This symbol contains the value of sizeof(short) so that the C + * preprocessor can make decisions based on it. + */ +#define INTSIZE 4 /**/ +#define LONGSIZE 4 /**/ +#define SHORTSIZE 2 /**/ + +/* Free_t: + * This variable contains the return type of free(). It is usually + * void, but occasionally int. + */ +/* Malloc_t: + * This symbol is the type of pointer returned by malloc and realloc. + */ +#define Malloc_t void * /**/ +#define Free_t void /**/ + +/* VAL_O_NONBLOCK: + * This symbol is to be used during open() or fcntl(F_SETFL) to turn on + * non-blocking I/O for the file descriptor. Note that there is no way + * back, i.e. you cannot turn it blocking again this way. If you wish to + * alternatively switch between blocking and non-blocking, use the + * ioctl(FIOSNBIO) call instead, but that is not supported by all devices. + */ +/* VAL_EAGAIN: + * This symbol holds the errno error code set by read() when no data was + * present on the non-blocking file descriptor. + */ +/* RD_NODATA: + * This symbol holds the return code from read() when no data is present + * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is + * not defined, then you can't distinguish between no data and EOF by + * issuing a read(). You'll have to find another way to tell for sure! + */ +/* EOF_NONBLOCK: + * This symbol, if defined, indicates to the C program that a read() on + * a non-blocking file descriptor will return 0 on EOF, and not the value + * held in RD_NODATA (-1 usually, in that case!). + */ +#define VAL_O_NONBLOCK O_NONBLOCK +#define VAL_EAGAIN EAGAIN +#define RD_NODATA -1 +#define EOF_NONBLOCK + +/* OLDARCHLIB_EXP: + * This symbol contains the ~name expanded version of OLDARCHLIB, to be + * used in programs that are not prepared to deal with ~ expansion at + * run-time. + */ +#undef OLDARCHLIB_EXP /**/ +#undef OLDARCHLIB /**/ + +/* PRIVLIB_EXP: + * 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_EXP "/sys/lib/perl" /* */ +#define PRIVLIB "/sys/lib/perl" /* */ + +/* SIG_NAME: + * This symbol contains a list of signal names in order of + * signal number. This is intended + * to be used as a static array initialization, like this: + * char *sig_name[] = { SIG_NAME }; + * The signals in the list are separated with commas, and each signal + * is surrounded by double quotes. There is no leading SIG in the signal + * name, i.e. SIGQUIT is known as "QUIT". + * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn, + * etc., where nn is the actual signal number (e.g. NUM37). + * The signal number for sig_name[i] is stored in sig_num[i]. + * The last element is 0 to terminate the list with a NULL. This + * corresponds to the 0 at the end of the sig_num list. + */ +/* SIG_NUM: + * This symbol contains a list of signal numbers, in the same order as the + * SIG_NAME list. It is suitable for static array initialization, as in: + * int sig_num[] = { SIG_NUM }; + * The signals in the list are separated with commas, and the indices + * within that list and the SIG_NAME list match, so it's easy to compute + * the signal name from a number or vice versa at the price of a small + * dynamic linear lookup. + * Duplicates are allowed, but are moved to the end of the list. + * The signal number corresponding to sig_name[i] is sig_number[i]. + * if (i < NSIG) then sig_number[i] == i. + * The last element is 0, corresponding to the 0 at the end of + * the sig_name list. + */ +#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","ABRT","FPE","KILL","SEGV","PIPE","ALRM","TERM","USR1","USR2","CHLD","CONT","STOP","TSTP","TTIN","TTOU",0 /* config-skip */ +#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,0 /* config-skip */ + +/* SITELIB_EXP: + * This symbol contains the ~name expanded version of SITELIB, to be used + * in programs that are not prepared to deal with ~ expansion at run-time. + */ +#define SITELIB_EXP "/sys/lib/perl/site_perl" /* */ +#define SITELIB "/sys/lib/perl/site_perl" /* */ + +/* SITEARCH_EXP: + * 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_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION/site_perl" /* */ +#define SITEARCH "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION/site_perl" /* */ + +/* STARTPERL: + * This variable contains the string to put in front of a perl + * script to make sure (one hopes) that it runs with perl and not + * some shell. + */ +#define STARTPERL "#!/bin/perl" /**/ + +/* SH_PATH: + * Just here to shut up compiler warnings. +*/ +#define SH_PATH "/bin/rc" /**/ + +#define PERLIO_IS_STDIO /* config-skip */ +#undef I_SFIO + +/* USE_PERLIO: + * This symbol, if defined, indicates that the PerlIO abstraction should + * be used throughout. If not defined, stdio should be + * used in a fully backward compatible manner. + */ +#undef USE_PERLIO /**/ + +/* USE_SFIO: + * This symbol, if defined, indicates that sfio should + * be used. + */ +#undef USE_SFIO /**/ + +/* HAS_GETPGID: + * This symbol, if defined, indicates to the C program that + * the getpgid(pid) function is available to get the + * process group id. + */ +#undef HAS_GETPGID /**/ + +/* I_SYS_RESOURCE: + * This symbol, if defined, indicates to the C program that it should + * include <sys/resource.h>. + */ +#define I_SYS_RESOURCE /**/ + +/* I_SYS_WAIT: + * This symbol, if defined, indicates to the C program that it should + * include <sys/wait.h>. + */ +#define I_SYS_WAIT /**/ + +/* I_VALUES: + * This symbol, if defined, indicates to the C program that it should + * include <values.h> to get definition of symbols like MINFLOAT or + * MAXLONG, i.e. machine dependant limitations. Probably, you + * should use <limits.h> instead, if it is available. + */ +#undef I_VALUES /**/ + +/* VOIDFLAGS: + * This symbol indicates how much support of the void type is given by this + * compiler. What various bits mean: + * + * 1 = supports declaration of void + * 2 = supports arrays of pointers to functions returning void + * 4 = supports comparisons between pointers to void functions and + * addresses of void functions + * 8 = suports declaration of generic void pointers + * + * The package designer should define VOIDUSED to indicate the requirements + * of the package. This can be done either by #defining VOIDUSED before + * including config.h, or by defining defvoidused in Myinit.U. If the + * latter approach is taken, only those flags will be tested. If the + * level of void support necessary is not present, defines void to int. + */ +#ifndef VOIDUSED +#define VOIDUSED 15 +#endif +#define VOIDFLAGS 15 +#if (VOIDFLAGS & VOIDUSED) != VOIDUSED +#define void int /* is void to be avoided? */ /* config-skip */ +#define M_VOID /* Xenix strikes again */ /* config-skip */ +#endif + +#endif diff --git a/gnu/usr.bin/perl/plan9/exclude b/gnu/usr.bin/perl/plan9/exclude new file mode 100644 index 00000000000..7d9fc3c8afd --- /dev/null +++ b/gnu/usr.bin/perl/plan9/exclude @@ -0,0 +1,18 @@ +comp/cpp.t +io/dup.t +io/fs.t +lib/anydbm.t +lib/complex.t +lib/filefind.t +lib/io_dup.t +lib/io_pipe.t +lib/io_sock.t +lib/io_udp.t +lib/posix.t +lib/socket.t +op/exec.t +op/goto.t +op/misc.t +op/oct.t +op/split.t +op/stat.t diff --git a/gnu/usr.bin/perl/plan9/fndvers b/gnu/usr.bin/perl/plan9/fndvers new file mode 100644 index 00000000000..a848de2b6db --- /dev/null +++ b/gnu/usr.bin/perl/plan9/fndvers @@ -0,0 +1,14 @@ +#!/bin/rc + +. plan9/buildinfo + +ed plan9/config.plan9 <<! +g/_P9P_VERSION/s//$p9pvers/g +g/_P9P_OBJTYPE/s//$objtype/g +w config.h +! + +ed plan9/genconfig.pl<<! +g/_P9P_VERSION/s//$p9pvers/g +w plan9/genconfig.pl +! diff --git a/gnu/usr.bin/perl/plan9/genconfig.pl b/gnu/usr.bin/perl/plan9/genconfig.pl new file mode 100644 index 00000000000..458c4c3ee9b --- /dev/null +++ b/gnu/usr.bin/perl/plan9/genconfig.pl @@ -0,0 +1,275 @@ +#!../miniperl +# Habit . . . +# +# Extract info from config.h, and add extra data here, to generate config.sh +# Edit the static information after __END__ to reflect your site and options +# that went into your perl binary. In addition, values which change from run +# to run may be supplied on the command line as key=val pairs. +# +# Last Modified: 28-Jun-1996 Luther Huffman lutherh@stratcom.com +# + +#==== Locations of installed Perl components +$p9pvers="_P9P_VERSION"; +$prefix=''; +$p9p_objtype=$ENV{'objtype'}; +$builddir="/sys/src/cmd/perl/$p9pvers"; +$installbin="/$p9p_objtype/bin"; +$installman1dir="/sys/man/1"; +$installman3dir="/sys/man/2"; +$installprivlib="/sys/lib/perl"; +$installarchlib = "/$p9p_objtype/lib/perl/$p9pvers"; +$archname="plan9_$p9p_objtype"; +$installsitelib="$installprivlib/site_perl"; +$installsitearch="$installarchlib/site_perl"; +$installscript="/bin"; + +unshift(@INC,'lib'); # In case someone didn't define Perl_Root + # before the build + +if ($ARGV[0] eq '-f') { + open(ARGS,$ARGV[1]) or die "Can't read data from $ARGV[1]: $!\n"; + @ARGV = (); + while (<ARGS>) { + push(@ARGV,split(/\|/,$_)); + } + close ARGS; +} + +if (-f "config.h") { $infile = "config.h"; $outdir = "../"; } +elsif (-f "plan9/config.h") { $infile = "plan9/config.h"; $outdir = "./"; } + +if ($infile) { print "Generating config.sh from $infile . . .\n"; } +else { die <<EndOfGasp; +Can't find config.h to read! + Please run this script from the perl source directory or + the plan9 subdirectory in the distribution. +EndOfGasp +} +$outdir = ''; +open(IN,"$infile") || die "Can't open $infile: $!\n"; +open(OUT,">${outdir}config.sh") || die "Can't open ${outdir}config.sh: $!\n"; + +$time = localtime; +$cf_by = $ENV{'user'}; +($vers = $]) =~ tr/./_/; + +# Plan 9 doesn't actually use version numbering. Following the original Unix +# precedent of assigning a Unix edition number based on the edition number +# of the manuals, I am referring to this as Plan 9, 1st edition. +$osvers = '1'; + +print OUT <<EndOfIntro; +# This file generated by genconfig.pl on a Plan 9 system. +# Input obtained from: +# $infile +# $0 +# Time: $time + +package='perl5' +CONFIG='true' +cf_time='$time' +cf_by='$cf_by' +ccdlflags='' +cccdlflags='' +libpth='$installprivlib' +ld='pcc' +lddlflags='' +ranlib='' +ar='ar' +nroff='/bin/nroff' +eunicefix=':' +hint='none' +hintfile='' +intsize='4' +longsize='4' +shortsize='2' +shrplib='define' +usemymalloc='n' +usevfork='true' +useposix='true' +spitshell='cat' +dlsrc='dl_none.c' +binexp='$installbin' +man1ext='' +man3ext='' +arch='$archname' +archname='$archname' +osname='plan9' +extensions='IO Socket Opcode Fcntl POSIX DynaLoader FileHandle' +osvers='$osvers' +sig_maxsig='19' +sig_name='ZERO HUP INT QUIT ILL ABRT FPE KILL SEGV PIPE ALRM TERM USR1 USR2 CHLD CONT STOP TSTP TTIN TTOU' +sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19' +sig_numsig='20' +prefix='$prefix' +builddir='$builddir' +installbin='$installbin' +installman1dir='$installman1dir' +installman3dir='$installman3dir' +installprivlib='$installprivlib' +installarchlib='$installarchlib' +installsitelib='$installsitelib' +installsitearch='$installsitearch' +installscript='$installscript' +scriptdir='$installscript' +scriptdirexp='$installscript' +EndOfIntro + +# Plan 9 compiler stuff +print OUT "cc='pcc'\n"; +print OUT "d_attribut='undef'\n"; +print OUT "d_socket='define'\n"; +print OUT "d_sockpair='define'\n"; +print OUT "d_sigsetjmp='define'\n"; +print OUT "sigjmp_buf='sigjmp_buf'\n"; +print OUT "sigsetjmp='sigsetjmp(buf,save_mask)'\n"; +print OUT "siglongjmp='siglongjmp(buf,retval) '\n"; +print OUT "exe_ext=''\n"; +if ($p9p_objtype eq '386') { + $objext = '.8'; + $alignbytes = '4'; + $cstflags = 2; +} +elsif ($p9p_objtype eq '68020') { + $objext = '.2'; + $alignbytes = '2'; + $cstflags = 0; +} +elsif ($p9p_objtype eq 'mips') { + $objext = '.v'; + $alignbytes = '8'; + $cstflags = 0; +} +elsif ($p9p_objtype eq 'sparc') { + $objext = '.k'; + $alignbytes = '4'; + $cstflags = 0; +} +print OUT "obj_ext='$objext'\n"; +print OUT "alignbytes='$alignbytes'\n"; +print OUT "castflags='$cstflags'\n"; + +$myname = $ENV{'site'} ; +($myhostname,$mydomain) = split(/\./,$myname,2); +print OUT "myhostname='$myhostname'\n" if $myhostname; +if ($mydomain) { + print OUT "mydomain='.$mydomain'\n"; + print OUT "perladmin='$cf_by\@$myhostname.$mydomain'\n"; + print OUT "cf_email='$cf_by\@$myhostname.$mydomain'\n"; +} +else { + print OUT "perladmin='$cf_by'\n"; + print OUT "cf_email='$cf_by'\n"; +} +print OUT "myuname='Plan9 $myname $osvers $p9p_objtype'\n"; + +# Before we read the C header file, find out what config.sh constants are +# equivalent to the C preprocessor macros +if (open(SH,"${outdir}config_h.SH")) { + while (<SH>) { + next unless m%^#(?!if).*\$%; + s/^#//; s!(.*?)\s*/\*.*!$1!; + my(@words) = split; + $words[1] =~ s/\(.*//; # Clip off args from macro + # Did we use a shell variable for the preprocessor directive? + if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; } + if (@words > 2) { # We may also have a shell var in the value + shift @words; # Discard preprocessor directive + my($token) = shift @words; # and keep constant name + my($word); + foreach $word (@words) { + next unless $word =~ m!\$(\w+)!; + $val_vars{$token} = $1; + last; + } + } + } + close SH; +} +else { warn "Couldn't read ${outfile}config_h.SH: $!\n"; } +$pp_vars{PLAN9} = 'define'; #Plan 9 specific + +# OK, now read the C header file, and retcon statements into config.sh +while (<IN>) { # roll through the comment header in config.h + last if /config-start/; +} + +while (<IN>) { + chop; + while (/\\\s*$/) { # pick up contination lines + my $line = $_; + $line =~ s/\\\s*$//; + $_ = <IN>; + s/^\s*//; + $_ = $line . $_; + } + next unless my ($blocked,$un,$token,$val) = + m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%; + if (/config-skip/) { + delete $pp_vars{$token} if exists $pp_vars{$token}; + delete $val_vars{$token} if exists $val_vars{$token}; + next; + } + $val =~ s!\s*/\*.*!!; # strip off trailing comment + my($had_val); # Maybe a macro with args that we just #undefd or commented + if (!length($val) and $val_vars{$token} and ($un || $blocked)) { + print OUT "$val_vars{$token}=''\n"; + delete $val_vars{$token}; + $had_val = 1; + } + $state = ($blocked || $un) ? 'undef' : 'define'; + if ($pp_vars{$token}) { + print OUT "$pp_vars{$token}='$state'\n"; + delete $pp_vars{$token}; + } + elsif (not length $val and not $had_val) { + # Wups -- should have been shell var for C preprocessor directive + warn "Constant $token not found in config_h.SH\n"; + $token =~ tr/A-Z/a-z/; + $token = "d_$token" unless $token =~ /^i_/; + print OUT "$token='$state'\n"; + } + next unless length $val; + $val =~ s/^"//; $val =~ s/"$//; # remove end quotes + $val =~ s/","/ /g; # make signal list look nice + + if ($val_vars{$token}) { + print OUT "$val_vars{$token}='$val'\n"; + if ($val_vars{$token} =~ s/exp$//) {print OUT "$val_vars{$token}='$val'\n";} + delete $val_vars{$token}; + } + elsif (!$pp_vars{$token}) { # Haven't seen it previously, either + warn "Constant $token not found in config_h.SH (val=|$val|)\n"; + $token =~ tr/A-Z/a-z/; + print OUT "$token='$val'\n"; + if ($token =~ s/exp$//) {print OUT "$token='$val'\n";} + } +} +close IN; + +foreach (sort keys %pp_vars) { + warn "Didn't see $_ in $infile\n"; +} +foreach (sort keys %val_vars) { + warn "Didn't see $_ in $infile(val)\n"; +} + + +# print OUT "libs='",join(' ',@libs),"'\n"; +# print OUT "libc='",join(' ',@crtls),"'\n"; + +if (open(PL,"${outdir}patchlevel.h")) { + while (<PL>) { + if (/^#define PATCHLEVEL\s+(\S+)/) { print OUT "PATCHLEVEL='$1'\n"; } + elsif (/^#define SUBVERSION\s+(\S+)/) { print OUT "SUBVERSION='$1'\n"; } + } + close PL; +} +else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; } + +print OUT "pager='/bin/p'\n"; + +close OUT; + + diff --git a/gnu/usr.bin/perl/plan9/mkfile b/gnu/usr.bin/perl/plan9/mkfile new file mode 100644 index 00000000000..e56aa3c472c --- /dev/null +++ b/gnu/usr.bin/perl/plan9/mkfile @@ -0,0 +1,143 @@ +APE=/sys/src/ape +< $APE/config +<plan9/buildinfo +sourcedir = /sys/src/cmd/perl/$p9pvers +archname = plan9_$objtype +privlib=/sys/lib/perl +archlib = /$objtype/lib/perl/$p9pvers +sitelib = $privlib/site_perl +sitearch = $archlib/site_perl + +CFLAGS = -B -D_POSIX_SOURCE -D_BSD_EXTENSION -DMY_UV_MAX=0x7fffffffUL +LDFLAGS = -B + +CCCMD = $CC -c $CFLAGS + +perllib = $archlib/CORE/libperl.a + +perlshr = $archlib/CORE/libperlshr.a + +installman1dir = /sys/man/1 +installman3dir = /sys/man/2 + +podnames = perl perlbook perlbot perlcall perldata perldebug perldiag perldsc perlembed perlform perlfunc perlguts perlipc perllol perlmod perlobj perlop perlpod perlre perlref perlrun perlsec perlstyle perlsub perlsyn perltie perltoc perltrap perlvar perlxs perlxstut + +libpods = ${podnames:%=pod/%.pod} + +perlpods = $libpods + +extensions = IO Socket Opcode DynaLoader Fcntl POSIX +ext_xs = IO.xs Socket.xs Opcode.xs dl_none.xs Fcntl.xs POSIX.xs +ext_c = ${ext_xs:%.xs=%.c} +ext_obj = ${ext_xs:%.xs=%.$O} + +obj = gv.$O toke.$O perly.$O op.$O regcomp.$O dump.$O util.$O mg.$O hv.$O av.$O run.$O pp_hot.$O sv.$O pp.$O scope.$O pp_ctl.$O pp_sys.$O doop.$O doio.$O regexec.$O taint.$O deb.$O globals.$O plan9.$O universal.$O perlio.$O + +OBJS = perl.$O $obj + +testlist = base/*.t comp/*.t cmd/*.t io/*.t op/*.t + +install:V: perl preplibrary + cp perl /$objtype/bin/perl + cp plan9/aperl /rc/bin/Perl + mk man + +perl: config.h miniperlmain.$O miniperl $archlib/Config.pm perlmain.$O $perlshr + $LD $CFLAGS -o perl perlmain.$O $perllib $perlshr + +miniperl: config.h $perllib miniperlmain.$O + $LD $CFLAGS -o miniperl miniperlmain.$O $perllib + +preplibrary:V: miniperl $archlib/Config.pm + cd $privlib + for (file in *.pm */*.pm $archlib/Config.pm) $sourcedir/miniperl -e 'use AutoSplit; autosplit(@ARGV)' $file $privlib/auto + +$perllib(%):N: % +$perllib: ${OBJS:%=$perllib(%)} + ar rv $perllib $OBJS + $RANLIB $perllib + +miniperlmain.$O: config.h + $CCCMD miniperlmain.c + +perlmain.$O: config.h perlmain.c + $CCCMD perlmain.c + +perlmain.c: miniperl vms/writemain.pl + ./miniperl vms/writemain.pl $extensions + +config.h: plan9/fndvers + plan9/fndvers + cp config.h $archlib/CORE + +$perlshr(%):N: % +$perlshr: ${ext_obj:%=$perlshr(%)} + ar rv $perlshr $ext_obj + $RANLIB $perlshr + +IO.c: miniperl ext/IO/IO.xs + ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/IO/IO.xs > $target + cp ext/IO/*.pm $privlib + if (test !-d $privlib/IO) { + mkdir $privlib/IO + cp ext/IO/lib/IO/*.pm $privlib/IO + } + +Socket.$O: config.h Socket.c + $CCCMD -I plan9 Socket.c + +Socket.c: miniperl ext/Socket/Socket.xs + ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Socket/Socket.xs > $target + cp ext/Socket/Socket.pm $privlib + +Opcode.c: miniperl ext/Opcode/Opcode.xs + ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Opcode/Opcode.xs > $target + cp ext/Opcode/*.pm $privlib + +Fcntl.c: miniperl ext/Fcntl/Fcntl.xs + ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Fcntl/Fcntl.xs > $target + cp ext/Fcntl/Fcntl.pm $privlib + +POSIX.c: miniperl ext/POSIX/POSIX.xs + ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/POSIX/POSIX.xs > $target + cp ext/POSIX/POSIX.pm $privlib + +dl_none.c: miniperl ext/DynaLoader/dl_none.xs + ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/DynaLoader/dl_none.xs > $target + cp ext/DynaLoader/DynaLoader.pm $privlib + +test:V: + bind -b $privlib $sourcedir/lib + bind -b $archlib $sourcedir/lib + cd $sourcedir/t + rm -f perl + cp /$objtype/bin/perl $sourcedir/t + perl TEST `{ ls */*.t | comm -23 - ../plan9/exclude } + +plan9.$O: config.h ./plan9/plan9.c + cp ./plan9/plan9.c ./plan9.c + $CCCMD plan9.c + +%.$O: config.h %.c + $CCCMD $stem.c + +$archlib/Config.pm: miniperl config.sh + ./miniperl configpm $archlib/Config.pm + +config.sh: miniperl config.h + ./miniperl ./plan9/genconfig.pl + +installall:V: + for (objtype in 386 mips 68020 sparc) mk install + +man:V: $perlpods pod/pod2man.PL perl + perl pod/pod2man.PL + for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i + pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9 + +nuke clean:V: + rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c + rm -rf $privlib/IO + +deleteman:V: + rm -f $installman1dir/perl* $installman3dir/perl* diff --git a/gnu/usr.bin/perl/plan9/myconfig.plan9 b/gnu/usr.bin/perl/plan9/myconfig.plan9 new file mode 100644 index 00000000000..f336a7ce530 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/myconfig.plan9 @@ -0,0 +1,39 @@ +#!/bin/rc + +# This script is designed to provide a handy summary of the configuration +# information being used to build perl. This is especially useful if you +# are requesting help from comp.lang.perl.misc on usenet or via mail. + +#This script is the "myconfig" script altered to run on Plan 9. +#Last Modified: 28-Jun-96 Luther Huffman lutherh@stratcom.com + + +. config.sh + +# Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm. +# XXX Add d_sigaction (?) once it's defined. + +$spitshell<<!GROK!THIS! + +Summary of my $package ($baserev patchlevel $PATCHLEVEL) configuration: + Platform: + osname=$osname, osver=$osvers, archname=$archname + uname='$myuname' + hint=$hint, useposix=$useposix + Compiler: + cc='$cc', optimize='$optimize', gccversion=$gccversion + cppflags='$cppflags' + ccflags ='$ccflags' + stdchar='$stdchar', d_stdstdio=$d_stdstdio, usevfork=$usevfork + voidflags=$voidflags, castflags=$castflags, d_casti32=$d_casti32, d_castneg=$d_castneg + intsize=$intsize, alignbytes=$alignbytes, usemymalloc=$usemymalloc, randbits=$randbits + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth + libs=$libs + libc=$libc, so=$so + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' + cccdlflags='$cccdlflags', lddlflags='$lddlflags' + +!GROK!THIS! diff --git a/gnu/usr.bin/perl/plan9/perlplan9.doc b/gnu/usr.bin/perl/plan9/perlplan9.doc new file mode 100644 index 00000000000..d6d7df8b742 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/perlplan9.doc @@ -0,0 +1,91 @@ + + PLAN9/PERLPLAN9(1) (perl 5.003, patch 05) PLAN9/PERLPLAN9(1) + + NNNNAAAAMMMMEEEE + perlplan9 - Plan 9-specific documentation for Perl + + DDDDEEEESSSSCCCCRRRRIIIIPPPPTTTTIIIIOOOONNNN + These are a few notes describing features peculiar to Plan 9 + Perl. As such, it is not intended to be a replacement for + the rest of the Perl 5 documentation (which is both copious + and excellent). If you have any questions to which you can't + find answers in these man pages, contact Luther Huffman at + lutherh@stratcom.com and we'll try to answer them. + + IIIInnnnvvvvooookkkkiiiinnnngggg PPPPeeeerrrrllll + + Perl is invoked from the command line as described in the + _p_e_r_l manpage. Most perl scripts, however, do have a first + line such as "#!/usr/local/bin/perl". This is known as a + shebang (shell-bang) statement and tells the OS shell where + to find the perl interpreter. In Plan 9 Perl this statement + should be "#!/bin/perl" if you wish to be able to directly + invoke the script by its name. + Alternatively, you may invoke perl with the command + "Perl" instead of "perl". This will produce Acme-friendly + error messages of the form "filename:18". + + Some scripts, usually identified with a *.PL extension, are + self-configuring and are able to correctly create their own + shebang path from config information located in Plan 9 Perl. + These you won't need to be worried about. + + WWWWhhhhaaaatttt''''ssss iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll + + Although Plan 9 Perl currently only provides static + loading, it is built with a number of useful extensions. + These include Opcode, FileHandle, Fcntl, and POSIX. Expect + to see others (and DynaLoading!) in the future. + + WWWWhhhhaaaatttt''''ssss nnnnooootttt iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll + + As mentioned previously, dynamic loading isn't currently + available nor is MakeMaker. Both are high-priority items. + + PPPPeeeerrrrllll5555 FFFFuuuunnnnccccttttiiiioooonnnnssss nnnnooootttt ccccuuuurrrrrrrreeeennnnttttllllyyyy ssssuuuuppppppppoooorrrrtttteeeedddd + + Some, such as chown and umask aren't provided because the + concept does not exist within Plan 9. Others, such as some + of the socket-related functions, simply haven't been written + yet. Many in the latter category may be supported in the + future. + + The functions not currently implemented include: + + Page 1 9/Oct/96 (printed 10/9/96) + + PLAN9/PERLPLAN9(1) (perl 5.003, patch 05) PLAN9/PERLPLAN9(1) + + chown, chroot, dbmclose, dbmopen, getsockopt, + setsockopt, recvmsg, sendmsg, getnetbyname, + getnetbyaddr, getnetent, getprotoent, getservent, + sethostent, setnetent, setprotoent, setservent, + endservent, endnetent, endprotoent, umask + + There may be several other functions that have undefined + behavior so this list shouldn't be considered complete. + + SSSSiiiiggggnnnnaaaallllssss + + For compatibility with perl scripts written for the Unix + environment, Plan 9 Perl uses the POSIX signal emulation + provided in Plan 9's ANSI POSIX Environment (APE). Signal + stacking isn't supported. The signals provided are: + + SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT, + SIGFPE, SIGKILL, SIGSEGV, SIGPIPE, SIGPIPE, SIGALRM, + SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, + SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU + + BBBBUUUUGGGGSSSS + "As many as there are grains of sand on all the beaches of + the world . . ." - Carl Sagan + + RRRReeeevvvviiiissssiiiioooonnnn ddddaaaatttteeee + This document was revised 09-October-1996 for Perl 5.003_7. + + AAAAUUUUTTTTHHHHOOOORRRR + Luther Huffman, lutherh@stratcom.com + + Page 2 9/Oct/96 (printed 10/9/96) + diff --git a/gnu/usr.bin/perl/plan9/perlplan9.pod b/gnu/usr.bin/perl/plan9/perlplan9.pod new file mode 100644 index 00000000000..fb581494401 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/perlplan9.pod @@ -0,0 +1,87 @@ +=head1 NAME + +perlplan9 - Plan 9-specific documentation for Perl + +=head1 DESCRIPTION + +These are a few notes describing features peculiar to +Plan 9 Perl. As such, it is not intended to be a replacement +for the rest of the Perl 5 documentation (which is both +copious and excellent). If you have any questions to +which you can't find answers in these man pages, contact +Luther Huffman at lutherh@stratcom.com and we'll try to +answer them. + +=head2 Invoking Perl + +Perl is invoked from the command line as described in +L<perl>. Most perl scripts, however, do have a first line +such as "#!/usr/local/bin/perl". This is known as a shebang +(shell-bang) statement and tells the OS shell where to find +the perl interpreter. In Plan 9 Perl this statement should be +"#!/bin/perl" if you wish to be able to directly invoke the +script by its name. + Alternatively, you may invoke perl with the command "Perl" +instead of "perl". This will produce Acme-friendly error +messages of the form "filename:18". + +Some scripts, usually identified with a *.PL extension, are +self-configuring and are able to correctly create their own +shebang path from config information located in Plan 9 +Perl. These you won't need to be worried about. + +=head2 What's in Plan 9 Perl + +Although Plan 9 Perl currently only provides static +loading, it is built with a number of useful extensions. +These include Opcode, FileHandle, Fcntl, and POSIX. Expect +to see others (and DynaLoading!) in the future. + +=head2 What's not in Plan 9 Perl + +As mentioned previously, dynamic loading isn't currently +available nor is MakeMaker. Both are high-priority items. + +=head2 Perl5 Functions not currently supported + +Some, such as C<chown> and C<umask> aren't provided +because the concept does not exist within Plan 9. Others, +such as some of the socket-related functions, simply +haven't been written yet. Many in the latter category +may be supported in the future. + +The functions not currently implemented include: + + chown, chroot, dbmclose, dbmopen, getsockopt, + setsockopt, recvmsg, sendmsg, getnetbyname, + getnetbyaddr, getnetent, getprotoent, getservent, + sethostent, setnetent, setprotoent, setservent, + endservent, endnetent, endprotoent, umask + +There may be several other functions that have undefined +behavior so this list shouldn't be considered complete. + +=head2 Signals + +For compatibility with perl scripts written for the Unix +environment, Plan 9 Perl uses the POSIX signal emulation +provided in Plan 9's ANSI POSIX Environment (APE). Signal stacking +isn't supported. The signals provided are: + + SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT, + SIGFPE, SIGKILL, SIGSEGV, SIGPIPE, SIGPIPE, SIGALRM, + SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, + SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU + +=head1 BUGS + +"As many as there are grains of sand on all the beaches of the +world . . ." - Carl Sagan + +=head1 Revision date + +This document was revised 09-October-1996 for Perl 5.003_7. + +=head1 AUTHOR + +Luther Huffman, lutherh@stratcom.com diff --git a/gnu/usr.bin/perl/plan9/plan9.c b/gnu/usr.bin/perl/plan9/plan9.c new file mode 100644 index 00000000000..ebdac27dcb5 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/plan9.c @@ -0,0 +1,134 @@ +#include "EXTERN.h" +#include "perl.h" + +/* Functions mentioned in <sys/socket.h> but not implemented */ + +int getsockopt(int a, int b, int c, void *d, int *e) +{ + croak("Function \"getsockopt\" not implemented in this version of perl."); + return (int)NULL; +} + +int setsockopt(int a, int b, int c, void *d, int *e) +{ + croak("Function \"setsockopt\" not implemented in this version of perl."); + return (int)NULL; +} + + +int recvmsg(int a, struct msghdr *b, int c) +{ + croak("Function \"recvmsg\" not implemented in this version of perl."); + return (int)NULL; +} + +int sendmsg(int a, struct msghdr *b, int c) +{ + croak("Function \"sendmsg\" not implemented in this version of perl."); + return (int)NULL; +} + + +/* Functions mentioned in <netdb.h> but not implemented */ +struct netent *getnetbyname(const char *a) +{ + croak("Function \"getnetbyname\" not implemented in this version of perl."); + return (struct netent *)NULL; +} + +struct netent *getnetbyaddr(long a, int b) +{ + croak("Function \"getnetbyaddr\" not implemented in this version of perl."); + return (struct netent *)NULL; +} + +struct netent *getnetent() +{ + croak("Function \"getnetent\" not implemented in this version of perl."); + return (struct netent *)NULL; +} + +struct protoent *getprotobyname(const char *a) +{ + croak("Function \"getprotobyname\" not implemented in this version of perl."); + return (struct protoent *)NULL; +} + +struct protoent *getprotobynumber(int a) +{ + croak("Function \"getprotobynumber\" not implemented in this version of perl."); + return (struct protoent *)NULL; +} + +struct protoent *getprotoent() +{ + croak("Function \"getprotoent\" not implemented in this version of perl."); + return (struct protoent *)NULL; +} + +struct servent *getservbyport(int a, const char *b) +{ + croak("Function \"getservbyport\" not implemented in this version of perl."); + return (struct servent *)NULL; +} + +struct servent *getservent() +{ + croak("Function \"getservent\" not implemented in this version of perl."); + return (struct servent *)NULL; +} + +void sethostent(int a) +{ + croak("Function \"sethostent\" not implemented in this version of perl."); +} + +void setnetent(int a) +{ + croak("Function \"setnetent\" not implemented in this version of perl."); +} + +void setprotoent(int a) +{ + croak("Function \"setprotoent\" not implemented in this version of perl."); +} + +void setservent(int a) +{ + croak("Function \"setservent\" not implemented in this version of perl."); +} + +void endnetent() +{ + croak("Function \"endnetent\" not implemented in this version of perl."); +} + +void endprotoent() +{ + croak("Function \"endprotoent\" not implemented in this version of perl."); +} + +void endservent() +{ + croak("Function \"endservent\" not implemented in this version of perl."); +} + +int tcdrain(int) +{ +croak("Function \"tcdrain\" not implemented in this version of perl."); +} + +int tcflow(int, int) +{ +croak("Function \"tcflow\" not implemented in this version of perl."); +} + +int tcflush(int, int) +{ +croak("Function \"tcflush\" not implemented in this version of perl."); +} + +int tcsendbreak(int, int) +{ +croak("Function \"tcsendbreak\" not implemented in this version of perl."); +} diff --git a/gnu/usr.bin/perl/plan9/plan9ish.h b/gnu/usr.bin/perl/plan9/plan9ish.h new file mode 100644 index 00000000000..3a5ad5eb1a3 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/plan9ish.h @@ -0,0 +1,126 @@ +#ifndef __PLAN9ISH_H__ +#define __PLAN9ISH_H__ + +/* + * The following symbols are defined if your operating system supports + * functions by that name. All Unixes I know of support them, thus they + * are not checked by the configuration script, but are directly defined + * here. + */ + +/* HAS_IOCTL: + * This symbol, if defined, indicates that the ioctl() routine is + * available to set I/O characteristics + */ +#define HAS_IOCTL /**/ + +/* HAS_UTIME: + * This symbol, if defined, indicates that the routine utime() is + * available to update the access and modification times of files. + */ +#define HAS_UTIME /**/ + +/* HAS_GROUP + * This symbol, if defined, indicates that the getgrnam(), + * getgrgid(), and getgrent() routines are available to + * get group entries. + */ +/*#define HAS_GROUP /**/ + +/* HAS_PASSWD + * This symbol, if defined, indicates that the getpwnam(), + * getpwuid(), and getpwent() routines are available to + * get password entries. + */ +/*#define HAS_PASSWD /**/ + +#define HAS_KILL +#define HAS_WAIT + +/* UNLINK_ALL_VERSIONS: + * This symbol, if defined, indicates that the program should arrange + * to remove all versions of a file if unlink() is called. This is + * probably only relevant for VMS. + */ +/* #define UNLINK_ALL_VERSIONS /**/ + +/* PLAN9: + * This symbol, if defined, indicates that the program is running under + * Plan 9. + */ +#ifndef PLAN9 +#define PLAN9 /**/ +#endif + +/* USEMYBINMODE + * This symbol, if defined, indicates that the program should + * use the routine my_binmode(FILE *fp, char iotype) to insure + * that a file is in "binary" mode -- that is, that no translation + * of bytes occurs on read or write operations. + */ +#undef USEMYBINMODE + +/* USE_STAT_RDEV: +* This symbol is defined if this system has a stat structure declaring +* st_rdev +*/ +#undef USE_STAT_RDEV /**/ + +/* ACME_MESS: + * This symbol, if defined, indicates that error messages should be + * should be generated in a format that allows the use of the Acme + * GUI/editor's autofind feature. + */ +#define ACME_MESS /**/ + +/* ALTERNATE_SHEBANG: + * This symbol, if defined, contains a "magic" string which may be used + * as the first line of a Perl program designed to be executed directly + * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG + * begins with a character other then #, then Perl will only treat + * it as a command line if if finds the string "perl" in the first + * word; otherwise it's treated as the first line of code in the script. + * (IOW, Perl won't hand off to another interpreter via an alternate + * shebang sequence that might be legal Perl code.) + */ +/* #define ALTERNATE_SHEBANG "#!" / **/ + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +# include <signal.h> +#endif + +#ifndef SIGABRT +# define SIGABRT SIGILL +#endif +#ifndef SIGILL +# define SIGILL 6 /* blech */ +#endif +#define ABORT() kill(getpid(),SIGABRT); + +#define BIT_BUCKET "/dev/null" +#define PERL_SYS_INIT(c,v) +#define dXSUB_SYS +#define PERL_SYS_TERM() + +/* + * fwrite1() should be a routine with the same calling sequence as fwrite(), + * but which outputs all of the bytes requested as a single stream (unlike + * fwrite() itself, which on some systems outputs several distinct records + * if the number_of_items parameter is >1). + */ +#define fwrite1 fwrite + +#define Stat(fname,bufptr) stat((fname),(bufptr)) +#define Fstat(fd,bufptr) fstat((fd),(bufptr)) +#define Fflush(fp) fflush(fp) +#define Mkdir(path,mode) mkdir((path),(mode)) + +/* getenv related stuff */ +#define my_getenv(var) getenv(var) +/* Plan 9 prefers getenv("home") to getenv("HOME") +#define HOME home + +/* For use by POSIX.xs */ +extern int tcsendbreak(int, int); + +#endif /* __PLAN9ISH_H__ */ diff --git a/gnu/usr.bin/perl/plan9/setup.rc b/gnu/usr.bin/perl/plan9/setup.rc new file mode 100644 index 00000000000..dd96c1f9c7d --- /dev/null +++ b/gnu/usr.bin/perl/plan9/setup.rc @@ -0,0 +1,51 @@ +#!/bin/rc +# This is an rc shell script which unpacks the perl distribution, builds +# directories, and puts files where they belong. +# To use, just run it from within the plan9 subdirectory with the appropriate +# permissions. +# Last modified 6/30/96 by: +# Luther Huffman, Strategic Computer Solutions, Inc., lutherh@stratcom.com + +awk -f versnum ../patchlevel.h +. buildinfo +builddir = `{ cd .. ; pwd } +if (~ $#* 0) platforms = $objtype +if not switch($1) { + case -a ; platforms = (386 mips sparc 68020) + case * ; echo 'Usage: setup.rc [-a]' >[1=2] ; exit +} +sourcedir=/sys/src/cmd/perl/$p9pvers +privlib=/sys/lib/perl +sitelib=$privlib/site_perl + +#Build source directory +if (test ! -d /sys/src/cmd/perl) mkdir /sys/src/cmd/perl +if (test ! -d $sourcedir) mkdir $sourcedir + +#Populate source directory +echo Building source directories ... +{cd $builddir ; tar c .} | { cd $sourcedir ; tar x} +cp $builddir/plan9/plan9.c $builddir/plan9/plan9ish.h $builddir/plan9/mkfile $sourcedir +cd $sourcedir/lib ; rm -rf * + +#Build library directories +echo Building library directories ... +if (test ! -d $privlib) mkdir $privlib +if (test ! -d $privlib/auto) mkdir $privlib/auto +if (test ! -d $sitelib) mkdir $sitelib +for(i in $platforms){ + archlib=/$i/lib/perl/$p9pvers + sitearch=$archlib/site_perl + corelib=$archlib/CORE + arpalib=$corelib/arpa + if (test ! -d /$i/lib/perl) mkdir /$i/lib/perl + if (test ! -d $archlib) mkdir $archlib + if (test ! -d $sitearch) mkdir $sitearch + if (test ! -d $corelib) mkdir $corelib + if (test ! -d $arpalib) mkdir $arpalib + cp $builddir/*.h $builddir/plan9/*.h $corelib + cp $builddir/plan9/arpa/*.h $arpalib +} + +#Populate library directories +{cd $builddir/lib ; tar c . } | {cd $privlib ; tar x } diff --git a/gnu/usr.bin/perl/plan9/versnum b/gnu/usr.bin/perl/plan9/versnum new file mode 100644 index 00000000000..83e46826c34 --- /dev/null +++ b/gnu/usr.bin/perl/plan9/versnum @@ -0,0 +1,8 @@ +/PATCHLEVEL/ {base = $3} +/SUBVERSION/ {subvers = $3} +END { +if (subvers == 0) + printf "p9pvers = 5.%03d\n", base> "buildinfo"; +else + printf "p9pvers = 5.%03d_%02d\n" , base, subvers> "buildinfo"; +} diff --git a/gnu/usr.bin/perl/pod/checkpods.PL b/gnu/usr.bin/perl/pod/checkpods.PL new file mode 100644 index 00000000000..ccd78ec9cf0 --- /dev/null +++ b/gnu/usr.bin/perl/pod/checkpods.PL @@ -0,0 +1,75 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +# From roderick@gate.netThu Sep 5 17:19:30 1996 +# Date: Thu, 05 Sep 1996 00:11:22 -0400 +# From: Roderick Schertler <roderick@gate.net> +# To: perl5-porters@africa.nicoh.com +# Subject: POD lines with only spaces +# +# There are some places in the documentation where a POD directive is +# ignored because the line before it contains whitespace (and so the +# directive doesn't start a paragraph). This patch adds a way to check +# for these to the pod Makefile (though it isn't made part of the build +# process, which would be a good idea), and fixes those places where the +# problem currently exists. +# +# Version 1.00 Original. +# Version 1.01 Andy Dougherty <doughera@lafcol.lafayette.edu> +# Trivial modifications to output format for easier auto-parsing +# Broke it out as a separate function to avoid nasty +# Make/Shell/Perl quoting problems, and also to make it easier +# to grow. Someone will probably want to rewrite in terms of +# some sort of Pod::Checker module. Or something. Consider this +# a placeholder for the future. +$exit = $last_blank = 0; +while (<>) { + chop; + if (/^(=\S+)/ && $last_blank) { + printf "%s: line %5d, Non-empty line preceeding directive %s\n", + $ARGV, $., $1; + $exit = 1; + } + $last_blank = /^\s+$/; + if (eof) { + close(ARGV); + $last_blank = 0; + } +} +exit $exit +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/gnu/usr.bin/perl/pod/perlapio.pod b/gnu/usr.bin/perl/pod/perlapio.pod new file mode 100644 index 00000000000..c963d232f6c --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlapio.pod @@ -0,0 +1,274 @@ +=head1 NAME + +perlapio - perl's IO abstraction interface. + +=head1 SYNOPSIS + + PerlIO *PerlIO_stdin(void); + PerlIO *PerlIO_stdout(void); + PerlIO *PerlIO_stderr(void); + + PerlIO *PerlIO_open(const char *,const char *); + int PerlIO_close(PerlIO *); + + int PerlIO_stdoutf(const char *,...) + int PerlIO_puts(PerlIO *,const char *); + int PerlIO_putc(PerlIO *,int); + int PerlIO_write(PerlIO *,const void *,size_t); + int PerlIO_printf(PerlIO *, const char *,...); + int PerlIO_vprintf(PerlIO *, const char *, va_list); + int PerlIO_flush(PerlIO *); + + int PerlIO_eof(PerlIO *); + int PerlIO_error(PerlIO *); + void PerlIO_clearerr(PerlIO *); + + int PerlIO_getc(PerlIO *); + int PerlIO_ungetc(PerlIO *,int); + int PerlIO_read(PerlIO *,void *,size_t); + + int PerlIO_fileno(PerlIO *); + PerlIO *PerlIO_fdopen(int, const char *); + PerlIO *PerlIO_importFILE(FILE *, int flags); + FILE *PerlIO_exportFILE(PerlIO *, int flags); + FILE *PerlIO_findFILE(PerlIO *); + void PerlIO_releaseFILE(PerlIO *,FILE *); + + void PerlIO_setlinebuf(PerlIO *); + + long PerlIO_tell(PerlIO *); + int PerlIO_seek(PerlIO *,off_t,int); + int PerlIO_getpos(PerlIO *,Fpos_t *) + int PerlIO_setpos(PerlIO *,Fpos_t *) + void PerlIO_rewind(PerlIO *); + + int PerlIO_has_base(PerlIO *); + int PerlIO_has_cntptr(PerlIO *); + int PerlIO_fast_gets(PerlIO *); + int PerlIO_canset_cnt(PerlIO *); + + char *PerlIO_get_ptr(PerlIO *); + int PerlIO_get_cnt(PerlIO *); + void PerlIO_set_cnt(PerlIO *,int); + void PerlIO_set_ptrcnt(PerlIO *,char *,int); + char *PerlIO_get_base(PerlIO *); + int PerlIO_get_bufsiz(PerlIO *); + +=head1 DESCRIPTION + +Perl's source code should use the above functions instead of those +defined in ANSI C's I<stdio.h>, I<perlio.h> will the C<#define> them to +the I/O mechanism selected at Configure time. + +The functions are modeled on those in I<stdio.h>, but parameter order +has been "tidied up a little". + +=over 4 + +=item B<PerlIO *> + +This takes the place of FILE *. Unlike FILE * it should be treated as +opaque (it is probably safe to assume it is a pointer to something). + +=item B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()> + +Use these rather than C<stdin>, C<stdout>, C<stderr>. They are written +to look like "function calls" rather than variables because this makes +it easier to I<make them> function calls if platform cannot export data +to loaded modules, or if (say) different "threads" might have different +values. + +=item B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)> + +These correspond to fopen()/fdopen() arguments are the same. + +=item B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)> + +These are is fprintf()/vfprintf equivalents. + +=item B<PerlIO_stdoutf(fmt,...)> + +This is printf() equivalent. printf is #defined to this function, +so it is (currently) legal to use C<printf(fmt,...)> in perl sources. + +=item B<PerlIO_read(f,buf,count)>, B<PerlIO_write(f,buf,count)> + +These correspond to fread() and fwrite(). Note that arguments +are different, there is only one "count" and order has +"file" first. + +=item B<PerlIO_close(f)> + +=item B<PerlIO_puts(f,s)>, B<PerlIO_putc(f,c)> + +These correspond to fputs() and fputc(). +Note that arguments have been revised to have "file" first. + +=item B<PerlIO_ungetc(f,c)> + +This corresponds to ungetc(). +Note that arguments have been revised to have "file" first. + +=item B<PerlIO_getc(f)> + +This corresponds to getc(). + +=item B<PerlIO_eof(f)> + +This corresponds to feof(). + +=item B<PerlIO_error(f)> + +This corresponds to ferror(). + +=item B<PerlIO_fileno(f)> + +This corresponds to fileno(), note that on some platforms, +the meaning of "fileno" may not match Unix. + +=item B<PerlIO_clearerr(f)> + +This corresponds to clearerr(), i.e., clears 'eof' and 'error' +flags for the "stream". + +=item B<PerlIO_flush(f)> + +This corresponds to fflush(). + +=item B<PerlIO_tell(f)> + +This corresponds to ftell(). + +=item B<PerlIO_seek(f,o,w)> + +This corresponds to fseek(). + +=item B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)> + +These correspond to fgetpos() and fsetpos(). If platform does not +have the stdio calls then they are implemented in terms of PerlIO_tell() +and PerlIO_seek(). + +=item B<PerlIO_rewind(f)> + +This corresponds to rewind(). Note may be redefined +in terms of PerlIO_seek() at some point. + +=item B<PerlIO_tmpfile()> + +This corresponds to tmpfile(), i.e., returns an anonymous +PerlIO which will automatically be deleted when closed. + +=back + +=head2 Co-existence with stdio + +There is outline support for co-existence of PerlIO with stdio. +Obviously if PerlIO is implemented in terms of stdio there is +no problem. However if perlio is implemented on top of (say) sfio +then mechanisms must exist to create a FILE * which can be passed +to library code which is going to use stdio calls. + +=over 4 + +=item B<PerlIO_importFILE(f,flags)> + +Used to get a PerlIO * from a FILE *. +May need additional arguments, interface under review. + +=item B<PerlIO_exportFILE(f,flags)> + +Given an PerlIO * return a 'native' FILE * suitable for +passing to code expecting to be compiled and linked with +ANSI C I<stdio.h>. + +The fact that such a FILE * has been 'exported' is recorded, +and may affect future PerlIO operations on the original +PerlIO *. + +=item B<PerlIO_findFILE(f)> + +Returns previously 'exported' FILE * (if any). +Place holder until interface is fully defined. + +=item B<PerlIO_releaseFILE(p,f)> + +Calling PerlIO_releaseFILE informs PerlIO that all use +of FILE * is complete. It is removed from list of 'exported' +FILE *s, and associated PerlIO * should revert to original +behaviour. + +=item B<PerlIO_setlinebuf(f)> + +This corresponds to setlinebuf(). Use is deprecated pending +further discussion. (Perl core uses it I<only> when "dumping" +is has nothing to do with $| auto-flush.) + +=back + +In addition to user API above there is an "implementation" interface +which allows perl to get at internals of PerlIO. +The following calls correspond to the various FILE_xxx macros determined +by Configure. This section is really of interest to only those +concerned with detailed perl-core behaviour or implementing a +PerlIO mapping. + +=over 4 + +=item B<PerlIO_has_cntptr(f)> + +Implementation can return pointer to current position in the "buffer" and +a count of bytes available in the buffer. + +=item B<PerlIO_get_ptr(f)> + +Return pointer to next readable byte in buffer. + +=item B<PerlIO_get_cnt(f)> + +Return count of readable bytes in the buffer. + +=item B<PerlIO_canset_cnt(f)> + +Implementation can adjust its idea of number of +bytes in the buffer. + +=item B<PerlIO_fast_gets(f)> + +Implementation has all the interfaces required to +allow perl's fast code to handle <FILE> mechanism. + + PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \ + PerlIO_canset_cnt(f) && \ + `Can set pointer into buffer' + +=item B<PerlIO_set_ptrcnt(f,p,c)> + +Set pointer into buffer, and a count of bytes still in the +buffer. Should be used only to set +pointer to within range implied by previous calls +to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>. + +=item B<PerlIO_set_cnt(f,c)> + +Obscure - set count of bytes in the buffer. Deprecated. +Currently used in only doio.c to force count < -1 to -1. +Perhaps should be PerlIO_set_empty or similar. +This call may actually do nothing if "count" is deduced from pointer +and a "limit". + +=item B<PerlIO_has_base(f)> + +Implementation has a buffer, and can return pointer +to whole buffer and its size. Used by perl for B<-T> / B<-B> tests. +Other uses would be very obscure... + +=item B<PerlIO_get_base(f)> + +Return I<start> of buffer. + +=item B<PerlIO_get_bufsiz(f)> + +Return I<total size> of buffer. + +=back diff --git a/gnu/usr.bin/perl/pod/perldelta.pod b/gnu/usr.bin/perl/pod/perldelta.pod new file mode 100644 index 00000000000..7400940dcad --- /dev/null +++ b/gnu/usr.bin/perl/pod/perldelta.pod @@ -0,0 +1,1586 @@ +=head1 NAME + +perldelta - what's new for perl5.004 + +=head1 DESCRIPTION + +This document describes differences between the 5.003 release (as +documented in I<Programming Perl>, second edition--the Camel Book) and +this one. + +=head1 Supported Environments + +Perl5.004 builds out of the box on Unix, Plan 9, LynxOS, VMS, OS/2, +QNX, AmigaOS, and Windows NT. Perl runs on Windows 95 as well, but it +cannot be built there, for lack of a reasonable command interpreter. + +=head1 Core Changes + +Most importantly, many bugs were fixed, including several security +problems. See the F<Changes> file in the distribution for details. + +=head2 List assignment to %ENV works + +C<%ENV = ()> and C<%ENV = @list> now work as expected (except on VMS +where it generates a fatal error). + +=head2 "Can't locate Foo.pm in @INC" error now lists @INC + +=head2 Compilation option: Binary compatibility with 5.003 + +There is a new Configure question that asks if you want to maintain +binary compatibility with Perl 5.003. If you choose binary +compatibility, you do not have to recompile your extensions, but you +might have symbol conflicts if you embed Perl in another application, +just as in the 5.003 release. By default, binary compatibility +is preserved at the expense of symbol table pollution. + +=head2 $PERL5OPT environment variable + +You may now put Perl options in the $PERL5OPT environment variable. +Unless Perl is running with taint checks, it will interpret this +variable as if its contents had appeared on a "#!perl" line at the +beginning of your script, except that hyphens are optional. PERL5OPT +may only be used to set the following switches: B<-[DIMUdmw]>. + +=head2 Limitations on B<-M>, B<-m>, and B<-T> options + +The C<-M> and C<-m> options are no longer allowed on the C<#!> line of +a script. If a script needs a module, it should invoke it with the +C<use> pragma. + +The B<-T> option is also forbidden on the C<#!> line of a script, +unless it was present on the Perl command line. Due to the way C<#!> +works, this usually means that B<-T> must be in the first argument. +Thus: + + #!/usr/bin/perl -T -w + +will probably work for an executable script invoked as C<scriptname>, +while: + + #!/usr/bin/perl -w -T + +will probably fail under the same conditions. (Non-Unix systems will +probably not follow this rule.) But C<perl scriptname> is guaranteed +to fail, since then there is no chance of B<-T> being found on the +command line before it is found on the C<#!> line. + +=head2 More precise warnings + +If you removed the B<-w> option from your Perl 5.003 scripts because it +made Perl too verbose, we recommend that you try putting it back when +you upgrade to Perl 5.004. Each new perl version tends to remove some +undesirable warnings, while adding new warnings that may catch bugs in +your scripts. + +=head2 Deprecated: Inherited C<AUTOLOAD> for non-methods + +Before Perl 5.004, C<AUTOLOAD> functions were looked up as methods +(using the C<@ISA> hierarchy), even when the function to be autoloaded +was called as a plain function (e.g. C<Foo::bar()>), not a method +(e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>). + +Perl 5.005 will use method lookup only for methods' C<AUTOLOAD>s. +However, there is a significant base of existing code that may be using +the old behavior. So, as an interim step, Perl 5.004 issues an optional +warning when a non-method uses an inherited C<AUTOLOAD>. + +The simple rule is: Inheritance will not work when autoloading +non-methods. The simple fix for old code is: In any module that used to +depend on inheriting C<AUTOLOAD> for non-methods from a base class named +C<BaseClass>, execute C<*AUTOLOAD = \&BaseClass::AUTOLOAD> during startup. + +=head2 Previously deprecated %OVERLOAD is no longer usable + +Using %OVERLOAD to define overloading was deprecated in 5.003. +Overloading is now defined using the overload pragma. %OVERLOAD is +still used internally but should not be used by Perl scripts. See +L<overload> for more details. + +=head2 Subroutine arguments created only when they're modified + +In Perl 5.004, nonexistent array and hash elements used as subroutine +parameters are brought into existence only if they are actually +assigned to (via C<@_>). + +Earlier versions of Perl vary in their handling of such arguments. +Perl versions 5.002 and 5.003 always brought them into existence. +Perl versions 5.000 and 5.001 brought them into existence only if +they were not the first argument (which was almost certainly a bug). +Earlier versions of Perl never brought them into existence. + +For example, given this code: + + undef @a; undef %a; + sub show { print $_[0] }; + sub change { $_[0]++ }; + show($a[2]); + change($a{b}); + +After this code executes in Perl 5.004, $a{b} exists but $a[2] does +not. In Perl 5.002 and 5.003, both $a{b} and $a[2] would have existed +(but $a[2]'s value would have been undefined). + +=head2 Group vector changeable with C<$)> + +The C<$)> special variable has always (well, in Perl 5, at least) +reflected not only the current effective group, but also the group list +as returned by the C<getgroups()> C function (if there is one). +However, until this release, there has not been a way to call the +C<setgroups()> C function from Perl. + +In Perl 5.004, assigning to C<$)> is exactly symmetrical with examining +it: The first number in its string value is used as the effective gid; +if there are any numbers after the first one, they are passed to the +C<setgroups()> C function (if there is one). + +=head2 Fixed parsing of $$<digit>, &$<digit>, etc. + +Perl versions before 5.004 misinterpreted any type marker followed by +"$" and a digit. For example, "$$0" was incorrectly taken to mean +"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004. + +However, the developers of Perl 5.004 could not fix this bug completely, +because at least two widely-used modules depend on the old meaning of +"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the +old (broken) way inside strings; but it generates this message as a +warning. And in Perl 5.005, this special treatment will cease. + +=head2 Fixed localization of $<digit>, $&, etc. + +Perl versions before 5.004 did not always properly localize the +regex-related special variables. Perl 5.004 does localize them, as +the documentation has always said it should. This may result in $1, +$2, etc. no longer being set where existing programs use them. + +=head2 No resetting of $. on implicit close + +The documentation for Perl 5.0 has always stated that C<$.> is I<not> +reset when an already-open file handle is reopened with no intervening +call to C<close>. Due to a bug, perl versions 5.000 through 5.003 +I<did> reset C<$.> under that circumstance; Perl 5.004 does not. + +=head2 C<wantarray> may return undef + +The C<wantarray> operator returns true if a subroutine is expected to +return a list, and false otherwise. In Perl 5.004, C<wantarray> can +also return the undefined value if a subroutine's return value will +not be used at all, which allows subroutines to avoid a time-consuming +calculation of a return value if it isn't going to be used. + +=head2 Changes to tainting checks + +A bug in previous versions may have failed to detect some insecure +conditions when taint checks are turned on. (Taint checks are used +in setuid or setgid scripts, or when explicitly turned on with the +C<-T> invocation option.) Although it's unlikely, this may cause a +previously-working script to now fail -- which should be construed +as a blessing, since that indicates a potentially-serious security +hole was just plugged. + +The new restrictions when tainting include: + +=over + +=item No glob() or <*> + +These operators may spawn the C shell (csh), which cannot be made +safe. This restriction will be lifted in a future version of Perl +when globbing is implemented without the use of an external program. + +=item No spawning if tainted $CDPATH, $ENV, $BASH_ENV + +These environment variables may alter the behavior of spawned programs +(especially shells) in ways that subvert security. So now they are +treated as dangerous, in the manner of $IFS and $PATH. + +=item No spawning if tainted $TERM doesn't look like a terminal name + +Some termcap libraries do unsafe things with $TERM. However, it would be +unnecessarily harsh to treat all $TERM values as unsafe, since only shell +metacharacters can cause trouble in $TERM. So a tainted $TERM is +considered to be safe if it contains only alphanumerics, underscores, +dashes, and colons, and unsafe if it contains other characters (including +whitespace). + +=back + +=head2 New Opcode module and revised Safe module + +A new Opcode module supports the creation, manipulation and +application of opcode masks. The revised Safe module has a new API +and is implemented using the new Opcode module. Please read the new +Opcode and Safe documentation. + +=head2 Embedding improvements + +In older versions of Perl it was not possible to create more than one +Perl interpreter instance inside a single process without leaking like a +sieve and/or crashing. The bugs that caused this behavior have all been +fixed. However, you still must take care when embedding Perl in a C +program. See the updated perlembed manpage for tips on how to manage +your interpreters. + +=head2 Internal change: FileHandle class based on IO::* classes + +File handles are now stored internally as type IO::Handle. The +FileHandle module is still supported for backwards compatibility, but +it is now merely a front end to the IO::* modules -- specifically, +IO::Handle, IO::Seekable, and IO::File. We suggest, but do not +require, that you use the IO::* modules in new code. + +In harmony with this change, C<*GLOB{FILEHANDLE}> is now just a +backward-compatible synonym for C<*GLOB{IO}>. + +=head2 Internal change: PerlIO abstraction interface + +It is now possible to build Perl with AT&T's sfio IO package +instead of stdio. See L<perlapio> for more details, and +the F<INSTALL> file for how to use it. + +=head2 New and changed syntax + +=over + +=item $coderef->(PARAMS) + +A subroutine reference may now be suffixed with an arrow and a +(possibly empty) parameter list. This syntax denotes a call of the +referenced subroutine, with the given parameters (if any). + +This new syntax follows the pattern of S<C<$hashref-E<gt>{FOO}>> and +S<C<$aryref-E<gt>[$foo]>>: You may now write S<C<&$subref($foo)>> as +S<C<$subref-E<gt>($foo)>>. All of these arrow terms may be chained; +thus, S<C<&{$table-E<gt>{FOO}}($bar)>> may now be written +S<C<$table-E<gt>{FOO}-E<gt>($bar)>>. + +=back + +=head2 New and changed builtin constants + +=over + +=item __PACKAGE__ + +The current package name at compile time, or the undefined value if +there is no current package (due to a C<package;> directive). Like +C<__FILE__> and C<__LINE__>, C<__PACKAGE__> does I<not> interpolate +into strings. + +=back + +=head2 New and changed builtin variables + +=over + +=item $^E + +Extended error message on some platforms. (Also known as +$EXTENDED_OS_ERROR if you C<use English>). + +=item $^H + +The current set of syntax checks enabled by C<use strict>. See the +documentation of C<strict> for more details. Not actually new, but +newly documented. +Because it is intended for internal use by Perl core components, +there is no C<use English> long name for this variable. + +=item $^M + +By default, running out of memory it is not trappable. However, if +compiled for this, Perl may use the contents of C<$^M> as an emergency +pool after die()ing with this message. Suppose that your Perl were +compiled with -DPERL_EMERGENCY_SBRK and used Perl's malloc. Then + + $^M = 'a' x (1<<16); + +would allocate a 64K buffer for use when in emergency. +See the F<INSTALL> file for information on how to enable this option. +As a disincentive to casual use of this advanced feature, +there is no C<use English> long name for this variable. + +=back + +=head2 New and changed builtin functions + +=over + +=item delete on slices + +This now works. (e.g. C<delete @ENV{'PATH', 'MANPATH'}>) + +=item flock + +is now supported on more platforms, prefers fcntl to lockf when +emulating, and always flushes before (un)locking. + +=item printf and sprintf + +Perl now implements these functions itself; it doesn't use the C +library function sprintf() any more, except for floating-point +numbers, and even then only known flags are allowed. As a result, it +is now possible to know which conversions and flags will work, and +what they will do. + +The new conversions in Perl's sprintf() are: + + %i a synonym for %d + %p a pointer (the address of the Perl value, in hexadecimal) + %n special: *stores* the number of characters output so far + into the next variable in the parameter list + +The new flags that go between the C<%> and the conversion are: + + # prefix octal with "0", hex with "0x" + h interpret integer as C type "short" or "unsigned short" + V interpret integer as Perl's standard integer type + +Also, where a number would appear in the flags, an asterisk ("*") may +be used instead, in which case Perl uses the next item in the +parameter list as the given number (that is, as the field width or +precision). If a field width obtained through "*" is negative, it has +the same effect as the '-' flag: left-justification. + +See L<perlfunc/sprintf> for a complete list of conversion and flags. + +=item keys as an lvalue + +As an lvalue, C<keys> allows you to increase the number of hash buckets +allocated for the given hash. This can gain you a measure of efficiency if +you know the hash is going to get big. (This is similar to pre-extending +an array by assigning a larger number to $#array.) If you say + + keys %hash = 200; + +then C<%hash> will have at least 200 buckets allocated for it. These +buckets will be retained even if you do C<%hash = ()>; use C<undef +%hash> if you want to free the storage while C<%hash> is still in scope. +You can't shrink the number of buckets allocated for the hash using +C<keys> in this way (but you needn't worry about doing this by accident, +as trying has no effect). + +=item my() in Control Structures + +You can now use my() (with or without the parentheses) in the control +expressions of control structures such as: + + while (defined(my $line = <>)) { + $line = lc $line; + } continue { + print $line; + } + + if ((my $answer = <STDIN>) =~ /^y(es)?$/i) { + user_agrees(); + } elsif ($answer =~ /^n(o)?$/i) { + user_disagrees(); + } else { + chomp $answer; + die "`$answer' is neither `yes' nor `no'"; + } + +Also, you can declare a foreach loop control variable as lexical by +preceding it with the word "my". For example, in: + + foreach my $i (1, 2, 3) { + some_function(); + } + +$i is a lexical variable, and the scope of $i extends to the end of +the loop, but not beyond it. + +Note that you still cannot use my() on global punctuation variables +such as $_ and the like. + +=item pack() and unpack() + +A new format 'w' represents a BER compressed integer (as defined in +ASN.1). Its format is a sequence of one or more bytes, each of which +provides seven bits of the total value, with the most significant +first. Bit eight of each byte is set, except for the last byte, in +which bit eight is clear. + +If 'p' or 'P' are given undef as values, they now generate a NULL +pointer. + +Both pack() and unpack() now fail when their templates contain invalid +types. (Invalid types used to be ignored.) + +=item sysseek() + +The new sysseek() operator is a variant of seek() that sets and gets the +file's system read/write position, using the lseek(2) system call. It is +the only reliable way to seek before using sysread() or syswrite(). Its +return value is the new position, or the undefined value on failure. + +=item use VERSION + +If the first argument to C<use> is a number, it is treated as a version +number instead of a module name. If the version of the Perl interpreter +is less than VERSION, then an error message is printed and Perl exits +immediately. Because C<use> occurs at compile time, this check happens +immediately during the compilation process, unlike C<require VERSION>, +which waits until runtime for the check. This is often useful if you +need to check the current Perl version before C<use>ing library modules +which have changed in incompatible ways from older versions of Perl. +(We try not to do this more than we have to.) + +=item use Module VERSION LIST + +If the VERSION argument is present between Module and LIST, then the +C<use> will call the VERSION method in class Module with the given +version as an argument. The default VERSION method, inherited from +the UNIVERSAL class, croaks if the given version is larger than the +value of the variable $Module::VERSION. (Note that there is not a +comma after VERSION!) + +This version-checking mechanism is similar to the one currently used +in the Exporter module, but it is faster and can be used with modules +that don't use the Exporter. It is the recommended method for new +code. + +=item prototype(FUNCTION) + +Returns the prototype of a function as a string (or C<undef> if the +function has no prototype). FUNCTION is a reference to or the name of the +function whose prototype you want to retrieve. +(Not actually new; just never documented before.) + +=item srand + +The default seed for C<srand>, which used to be C<time>, has been changed. +Now it's a heady mix of difficult-to-predict system-dependent values, +which should be sufficient for most everyday purposes. + +Previous to version 5.004, calling C<rand> without first calling C<srand> +would yield the same sequence of random numbers on most or all machines. +Now, when perl sees that you're calling C<rand> and haven't yet called +C<srand>, it calls C<srand> with the default seed. You should still call +C<srand> manually if your code might ever be run on a pre-5.004 system, +of course, or if you want a seed other than the default. + +=item $_ as Default + +Functions documented in the Camel to default to $_ now in +fact do, and all those that do are so documented in L<perlfunc>. + +=item C<m//gc> does not reset search position on failure + +The C<m//g> match iteration construct has always reset its target +string's search position (which is visible through the C<pos> operator) +when a match fails; as a result, the next C<m//g> match after a failure +starts again at the beginning of the string. With Perl 5.004, this +reset may be disabled by adding the "c" (for "continue") modifier, +i.e. C<m//gc>. This feature, in conjunction with the C<\G> zero-width +assertion, makes it possible to chain matches together. See L<perlop> +and L<perlre>. + +=item C<m//x> ignores whitespace before ?*+{} + +The C<m//x> construct has always been intended to ignore all unescaped +whitespace. However, before Perl 5.004, whitespace had the effect of +escaping repeat modifiers like "*" or "?"; for example, C</a *b/x> was +(mis)interpreted as C</a\*b/x>. This bug has been fixed in 5.004. + +=item nested C<sub{}> closures work now + +Prior to the 5.004 release, nested anonymous functions didn't work +right. They do now. + +=item formats work right on changing lexicals + +Just like anonymous functions that contain lexical variables +that change (like a lexical index variable for a C<foreach> loop), +formats now work properly. For example, this silently failed +before (printed only zeros), but is fine now: + + my $i; + foreach $i ( 1 .. 10 ) { + write; + } + format = + my i is @# + $i + . + +However, it still fails (without a warning) if the foreach is within a +subroutine: + + my $i; + sub foo { + foreach $i ( 1 .. 10 ) { + write; + } + } + foo; + format = + my i is @# + $i + . + +=back + +=head2 New builtin methods + +The C<UNIVERSAL> package automatically contains the following methods that +are inherited by all other classes: + +=over + +=item isa(CLASS) + +C<isa> returns I<true> if its object is blessed into a subclass of C<CLASS> + +C<isa> is also exportable and can be called as a sub with two arguments. This +allows the ability to check what a reference points to. Example: + + use UNIVERSAL qw(isa); + + if(isa($ref, 'ARRAY')) { + ... + } + +=item can(METHOD) + +C<can> checks to see if its object has a method called C<METHOD>, +if it does then a reference to the sub is returned; if it does not then +I<undef> is returned. + +=item VERSION( [NEED] ) + +C<VERSION> returns the version number of the class (package). If the +NEED argument is given then it will check that the current version (as +defined by the $VERSION variable in the given package) not less than +NEED; it will die if this is not the case. This method is normally +called as a class method. This method is called automatically by the +C<VERSION> form of C<use>. + + use A 1.2 qw(some imported subs); + # implies: + A->VERSION(1.2); + +=back + +B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and +C<isa> uses a very similar method and caching strategy. This may cause +strange effects if the Perl code dynamically changes @ISA in any package. + +You may add other methods to the UNIVERSAL class via Perl or XS code. +You do not need to C<use UNIVERSAL> in order to make these methods +available to your program. This is necessary only if you wish to +have C<isa> available as a plain subroutine in the current package. + +=head2 TIEHANDLE now supported + +See L<perltie> for other kinds of tie()s. + +=over + +=item TIEHANDLE classname, LIST + +This is the constructor for the class. That means it is expected to +return an object of some sort. The reference can be used to +hold some internal information. + + sub TIEHANDLE { + print "<shout>\n"; + my $i; + return bless \$i, shift; + } + +=item PRINT this, LIST + +This method will be triggered every time the tied handle is printed to. +Beyond its self reference it also expects the list that was passed to +the print function. + + sub PRINT { + $r = shift; + $$r++; + return print join( $, => map {uc} @_), $\; + } + +=item PRINTF this, LIST + +This method will be triggered every time the tied handle is printed to +with the C<printf()> function. +Beyond its self reference it also expects the format and list that was +passed to the printf function. + + sub PRINTF { + shift; + my $fmt = shift; + print sprintf($fmt, @_)."\n"; + } + +=item READ this LIST + +This method will be called when the handle is read from via the C<read> +or C<sysread> functions. + + sub READ { + $r = shift; + my($buf,$len,$offset) = @_; + print "READ called, \$buf=$buf, \$len=$len, \$offset=$offset"; + } + +=item READLINE this + +This method will be called when the handle is read from. The method +should return undef when there is no more data. + + sub READLINE { + $r = shift; + return "PRINT called $$r times\n" + } + +=item GETC this + +This method will be called when the C<getc> function is called. + + sub GETC { print "Don't GETC, Get Perl"; return "a"; } + +=item DESTROY this + +As with the other types of ties, this method will be called when the +tied handle is about to be destroyed. This is useful for debugging and +possibly for cleaning up. + + sub DESTROY { + print "</shout>\n"; + } + +=back + +=head2 Malloc enhancements + +If perl is compiled with the malloc included with the perl distribution +(that is, if C<perl -V:d_mymalloc> is 'define') then you can print +memory statistics at runtime by running Perl thusly: + + env PERL_DEBUG_MSTATS=2 perl your_script_here + +The value of 2 means to print statistics after compilation and on +exit; with a value of 1, the statistics are printed only on exit. +(If you want the statistics at an arbitrary time, you'll need to +install the optional module Devel::Peek.) + +Three new compilation flags are recognized by malloc.c. (They have no +effect if perl is compiled with system malloc().) + +=over + +=item -DPERL_EMERGENCY_SBRK + +If this macro is defined, running out of memory need not be a fatal +error: a memory pool can allocated by assigning to the special +variable C<$^M>. See L<"$^M">. + +=item -DPACK_MALLOC + +Perl memory allocation is by bucket with sizes close to powers of two. +Because of these malloc overhead may be big, especially for data of +size exactly a power of two. If C<PACK_MALLOC> is defined, perl uses +a slightly different algorithm for small allocations (up to 64 bytes +long), which makes it possible to have overhead down to 1 byte for +allocations which are powers of two (and appear quite often). + +Expected memory savings (with 8-byte alignment in C<alignbytes>) is +about 20% for typical Perl usage. Expected slowdown due to additional +malloc overhead is in fractions of a percent (hard to measure, because +of the effect of saved memory on speed). + +=item -DTWO_POT_OPTIMIZE + +Similarly to C<PACK_MALLOC>, this macro improves allocations of data +with size close to a power of two; but this works for big allocations +(starting with 16K by default). Such allocations are typical for big +hashes and special-purpose scripts, especially image processing. + +On recent systems, the fact that perl requires 2M from system for 1M +allocation will not affect speed of execution, since the tail of such +a chunk is not going to be touched (and thus will not require real +memory). However, it may result in a premature out-of-memory error. +So if you will be manipulating very large blocks with sizes close to +powers of two, it would be wise to define this macro. + +Expected saving of memory is 0-100% (100% in applications which +require most memory in such 2**n chunks); expected slowdown is +negligible. + +=back + +=head2 Miscellaneous efficiency enhancements + +Functions that have an empty prototype and that do nothing but return +a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>). + +Each unique hash key is only allocated once, no matter how many hashes +have an entry with that key. So even if you have 100 copies of the +same hash, the hash keys never have to be reallocated. + +=head1 Support for More Operating Systems + +Support for the following operating systems is new in Perl 5.004. + +=head2 Win32 + +Perl 5.004 now includes support for building a "native" perl under +Windows NT, using the Microsoft Visual C++ compiler (versions 2.0 +and above) or the Borland C++ compiler (versions 5.02 and above). +The resulting perl can be used under Windows 95 (if it +is installed in the same directory locations as it got installed +in Windows NT). This port includes support for perl extension +building tools like L<MakeMaker> and L<h2xs>, so that many extensions +available on the Comprehensive Perl Archive Network (CPAN) can now be +readily built under Windows NT. See http://www.perl.com/ for more +information on CPAN, and L<README.win32> for more details on how to +get started with building this port. + +There is also support for building perl under the Cygwin32 environment. +Cygwin32 is a set of GNU tools that make it possible to compile and run +many UNIX programs under Windows NT by providing a mostly UNIX-like +interface for compilation and execution. See L<README.cygwin32> for +more details on this port, and how to obtain the Cygwin32 toolkit. + +=head2 Plan 9 + +See L<README.plan9>. + +=head2 QNX + +See L<README.qnx>. + +=head2 AmigaOS + +See L<README.amigaos>. + +=head1 Pragmata + +Six new pragmatic modules exist: + +=over + +=item use autouse MODULE => qw(sub1 sub2 sub3) + +Defers C<require MODULE> until someone calls one of the specified +subroutines (which must be exported by MODULE). This pragma should be +used with caution, and only when necessary. + +=item use blib + +=item use blib 'dir' + +Looks for MakeMaker-like I<'blib'> directory structure starting in +I<dir> (or current directory) and working back up to five levels of +parent directories. + +Intended for use on command line with B<-M> option as a way of testing +arbitrary scripts against an uninstalled version of a package. + +=item use constant NAME => VALUE + +Provides a convenient interface for creating compile-time constants, +See L<perlsub/"Constant Functions">. + +=item use locale + +Tells the compiler to enable (or disable) the use of POSIX locales for +builtin operations. + +When C<use locale> is in effect, the current LC_CTYPE locale is used +for regular expressions and case mapping; LC_COLLATE for string +ordering; and LC_NUMERIC for numeric formating in printf and sprintf +(but B<not> in print). LC_NUMERIC is always used in write, since +lexical scoping of formats is problematic at best. + +Each C<use locale> or C<no locale> affects statements to the end of +the enclosing BLOCK or, if not inside a BLOCK, to the end of the +current file. Locales can be switched and queried with +POSIX::setlocale(). + +See L<perllocale> for more information. + +=item use ops + +Disable unsafe opcodes, or any named opcodes, when compiling Perl code. + +=item use vmsish + +Enable VMS-specific language features. Currently, there are three +VMS-specific features available: 'status', which makes C<$?> and +C<system> return genuine VMS status values instead of emulating POSIX; +'exit', which makes C<exit> take a genuine VMS status value instead of +assuming that C<exit 1> is an error; and 'time', which makes all times +relative to the local time zone, in the VMS tradition. + +=back + +=head1 Modules + +=head2 Required Updates + +Though Perl 5.004 is compatible with almost all modules that work +with Perl 5.003, there are a few exceptions: + + Module Required Version for Perl 5.004 + ------ ------------------------------- + Filter Filter-1.12 + LWP libwww-perl-5.08 + Tk Tk400.202 (-w makes noise) + +Also, the majordomo mailing list program, version 1.94.1, doesn't work +with Perl 5.004 (nor with perl 4), because it executes an invalid +regular expression. This bug is fixed in majordomo version 1.94.2. + +=head2 Installation directories + +The I<installperl> script now places the Perl source files for +extensions in the architecture-specific library directory, which is +where the shared libraries for extensions have always been. This +change is intended to allow administrators to keep the Perl 5.004 +library directory unchanged from a previous version, without running +the risk of binary incompatibility between extensions' Perl source and +shared libraries. + +=head2 Module information summary + +Brand new modules, arranged by topic rather than strictly +alphabetically: + + CGI.pm Web server interface ("Common Gateway Interface") + CGI/Apache.pm Support for Apache's Perl module + CGI/Carp.pm Log server errors with helpful context + CGI/Fast.pm Support for FastCGI (persistent server process) + CGI/Push.pm Support for server push + CGI/Switch.pm Simple interface for multiple server types + + CPAN Interface to Comprehensive Perl Archive Network + CPAN::FirstTime Utility for creating CPAN configuration file + CPAN::Nox Runs CPAN while avoiding compiled extensions + + IO.pm Top-level interface to IO::* classes + IO/File.pm IO::File extension Perl module + IO/Handle.pm IO::Handle extension Perl module + IO/Pipe.pm IO::Pipe extension Perl module + IO/Seekable.pm IO::Seekable extension Perl module + IO/Select.pm IO::Select extension Perl module + IO/Socket.pm IO::Socket extension Perl module + + Opcode.pm Disable named opcodes when compiling Perl code + + ExtUtils/Embed.pm Utilities for embedding Perl in C programs + ExtUtils/testlib.pm Fixes up @INC to use just-built extension + + FindBin.pm Find path of currently executing program + + Class/Struct.pm Declare struct-like datatypes as Perl classes + File/stat.pm By-name interface to Perl's builtin stat + Net/hostent.pm By-name interface to Perl's builtin gethost* + Net/netent.pm By-name interface to Perl's builtin getnet* + Net/protoent.pm By-name interface to Perl's builtin getproto* + Net/servent.pm By-name interface to Perl's builtin getserv* + Time/gmtime.pm By-name interface to Perl's builtin gmtime + Time/localtime.pm By-name interface to Perl's builtin localtime + Time/tm.pm Internal object for Time::{gm,local}time + User/grent.pm By-name interface to Perl's builtin getgr* + User/pwent.pm By-name interface to Perl's builtin getpw* + + Tie/RefHash.pm Base class for tied hashes with references as keys + + UNIVERSAL.pm Base class for *ALL* classes + +=head2 Fcntl + +New constants in the existing Fcntl modules are now supported, +provided that your operating system happens to support them: + + F_GETOWN F_SETOWN + O_ASYNC O_DEFER O_DSYNC O_FSYNC O_SYNC + O_EXLOCK O_SHLOCK + +These constants are intended for use with the Perl operators sysopen() +and fcntl() and the basic database modules like SDBM_File. For the +exact meaning of these and other Fcntl constants please refer to your +operating system's documentation for fcntl() and open(). + +In addition, the Fcntl module now provides these constants for use +with the Perl operator flock(): + + LOCK_SH LOCK_EX LOCK_NB LOCK_UN + +These constants are defined in all environments (because where there is +no flock() system call, Perl emulates it). However, for historical +reasons, these constants are not exported unless they are explicitly +requested with the ":flock" tag (e.g. C<use Fcntl ':flock'>). + +=head2 IO + +The IO module provides a simple mechanism to load all of the IO modules at one +go. Currently this includes: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + +For more information on any of these modules, please see its +respective documentation. + +=head2 Math::Complex + +The Math::Complex module has been totally rewritten, and now supports +more operations. These are overloaded: + + + - * / ** <=> neg ~ abs sqrt exp log sin cos atan2 "" (stringify) + +And these functions are now exported: + + pi i Re Im arg + log10 logn ln cbrt root + tan + csc sec cot + asin acos atan + acsc asec acot + sinh cosh tanh + csch sech coth + asinh acosh atanh + acsch asech acoth + cplx cplxe + +=head2 Math::Trig + +This new module provides a simpler interface to parts of Math::Complex for +those who need trigonometric functions only for real numbers. + +=head2 DB_File + +There have been quite a few changes made to DB_File. Here are a few of +the highlights: + +=over + +=item * + +Fixed a handful of bugs. + +=item * + +By public demand, added support for the standard hash function exists(). + +=item * + +Made it compatible with Berkeley DB 1.86. + +=item * + +Made negative subscripts work with RECNO interface. + +=item * + +Changed the default flags from O_RDWR to O_CREAT|O_RDWR and the default +mode from 0640 to 0666. + +=item * + +Made DB_File automatically import the open() constants (O_RDWR, +O_CREAT etc.) from Fcntl, if available. + +=item * + +Updated documentation. + +=back + +Refer to the HISTORY section in DB_File.pm for a complete list of +changes. Everything after DB_File 1.01 has been added since 5.003. + +=head2 Net::Ping + +Major rewrite - support added for both udp echo and real icmp pings. + +=head2 Object-oriented overrides for builtin operators + +Many of the Perl builtins returning lists now have +object-oriented overrides. These are: + + File::stat + Net::hostent + Net::netent + Net::protoent + Net::servent + Time::gmtime + Time::localtime + User::grent + User::pwent + +For example, you can now say + + use File::stat; + use User::pwent; + $his = (stat($filename)->st_uid == pwent($whoever)->pw_uid); + +=head1 Utility Changes + +=head2 pod2html + +=over + +=item Sends converted HTML to standard output + +The I<pod2html> utility included with Perl 5.004 is entirely new. +By default, it sends the converted HTML to its standard output, +instead of writing it to a file like Perl 5.003's I<pod2html> did. +Use the B<--outfile=FILENAME> option to write to a file. + +=back + +=head2 xsubpp + +=over + +=item C<void> XSUBs now default to returning nothing + +Due to a documentation/implementation bug in previous versions of +Perl, XSUBs with a return type of C<void> have actually been +returning one value. Usually that value was the GV for the XSUB, +but sometimes it was some already freed or reused value, which would +sometimes lead to program failure. + +In Perl 5.004, if an XSUB is declared as returning C<void>, it +actually returns no value, i.e. an empty list (though there is a +backward-compatibility exception; see below). If your XSUB really +does return an SV, you should give it a return type of C<SV *>. + +For backward compatibility, I<xsubpp> tries to guess whether a +C<void> XSUB is really C<void> or if it wants to return an C<SV *>. +It does so by examining the text of the XSUB: if I<xsubpp> finds +what looks like an assignment to C<ST(0)>, it assumes that the +XSUB's return type is really C<SV *>. + +=back + +=head1 C Language API Changes + +=over + +=item C<gv_fetchmethod> and C<perl_call_sv> + +The C<gv_fetchmethod> function finds a method for an object, just like +in Perl 5.003. The GV it returns may be a method cache entry. +However, in Perl 5.004, method cache entries are not visible to users; +therefore, they can no longer be passed directly to C<perl_call_sv>. +Instead, you should use the C<GvCV> macro on the GV to extract its CV, +and pass the CV to C<perl_call_sv>. + +The most likely symptom of passing the result of C<gv_fetchmethod> to +C<perl_call_sv> is Perl's producing an "Undefined subroutine called" +error on the I<second> call to a given method (since there is no cache +on the first call). + +=item C<perl_eval_pv> + +A new function handy for eval'ing strings of Perl code inside C code. +This function returns the value from the eval statement, which can +be used instead of fetching globals from the symbol table. See +L<perlguts>, L<perlembed> and L<perlcall> for details and examples. + +=item Extended API for manipulating hashes + +Internal handling of hash keys has changed. The old hashtable API is +still fully supported, and will likely remain so. The additions to the +API allow passing keys as C<SV*>s, so that C<tied> hashes can be given +real scalars as keys rather than plain strings (nontied hashes still +can only use strings as keys). New extensions must use the new hash +access functions and macros if they wish to use C<SV*> keys. These +additions also make it feasible to manipulate C<HE*>s (hash entries), +which can be more efficient. See L<perlguts> for details. + +=back + +=head1 Documentation Changes + +Many of the base and library pods were updated. These +new pods are included in section 1: + +=over + +=item L<perldelta> + +This document. + +=item L<perlfaq> + +Frequently asked questions. + +=item L<perllocale> + +Locale support (internationalization and localization). + +=item L<perltoot> + +Tutorial on Perl OO programming. + +=item L<perlapio> + +Perl internal IO abstraction interface. + +=item L<perlmodlib> + +Perl module library and recommended practice for module creation. +Extracted from L<perlmod> (which is much smaller as a result). + +=item L<perldebug> + +Although not new, this has been massively updated. + +=item L<perlsec> + +Although not new, this has been massively updated. + +=back + +=head1 New Diagnostics + +Several new conditions will trigger warnings that were +silent before. Some only affect certain platforms. +The following new warnings and errors outline these. +These messages are classified as follows (listed in +increasing order of desperation): + + (W) A warning (optional). + (D) A deprecation (optional). + (S) A severe warning (mandatory). + (F) A fatal error (trappable). + (P) An internal error you should never see (trappable). + (X) A very fatal error (nontrappable). + (A) An alien error message (not generated by Perl). + +=over + +=item "my" variable %s masks earlier declaration in same scope + +(W) A lexical variable has been redeclared in the same scope, effectively +eliminating all access to the previous instance. This is almost always +a typographical error. Note that the earlier variable will still exist +until the end of the scope or until all closure referents to it are +destroyed. + +=item %s argument is not a HASH element or slice + +(F) The argument to delete() must be either a hash element, such as + + $foo{$bar} + $ref->[12]->{"susie"} + +or a hash slice, such as + + @foo{$bar, $baz, $xyzzy} + @{$ref->[12]}{"susie", "queue"} + +=item Allocation too large: %lx + +(X) You can't allocate more than 64K on an MS-DOS machine. + +=item Allocation too large + +(F) You can't allocate more than 2^31+"small amount" bytes. + +=item Applying %s to %s will act on scalar(%s) + +(W) The pattern match (//), substitution (s///), and translation (tr///) +operators work on scalar values. If you apply one of them to an array +or a hash, it will convert the array or hash to a scalar value -- the +length of an array, or the population info of a hash -- and then work on +that scalar value. This is probably not what you meant to do. See +L<perlfunc/grep> and L<perlfunc/map> for alternatives. + +=item Attempt to free nonexistent shared string + +(P) Perl maintains a reference counted internal table of strings to +optimize the storage and access of hash keys and other strings. This +indicates someone tried to decrement the reference count of a string +that can no longer be found in the table. + +=item Attempt to use reference as lvalue in substr + +(W) You supplied a reference as the first argument to substr() used +as an lvalue, which is pretty strange. Perhaps you forgot to +dereference it first. See L<perlfunc/substr>. + +=item Can't redefine active sort subroutine %s + +(F) Perl optimizes the internal handling of sort subroutines and keeps +pointers into them. You tried to redefine one such sort subroutine when it +was currently active, which is not allowed. If you really want to do +this, you should write C<sort { &func } @x> instead of C<sort func @x>. + +=item Can't use bareword ("%s") as %s ref while "strict refs" in use + +(F) Only hard references are allowed by "strict refs". Symbolic references +are disallowed. See L<perlref>. + +=item Cannot resolve method `%s' overloading `%s' in package `%s' + +(P) Internal error trying to resolve overloading specified by a method +name (as opposed to a subroutine reference). + +=item Constant subroutine %s redefined + +(S) You redefined a subroutine which had previously been eligible for +inlining. See L<perlsub/"Constant Functions"> for commentary and +workarounds. + +=item Constant subroutine %s undefined + +(S) You undefined a subroutine which had previously been eligible for +inlining. See L<perlsub/"Constant Functions"> for commentary and +workarounds. + +=item Copy method did not return a reference + +(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>. + +=item Died + +(F) You passed die() an empty string (the equivalent of C<die "">) or +you called it with no args and both C<$@> and C<$_> were empty. + +=item Exiting pseudo-block via %s + +(W) You are exiting a rather special block construct (like a sort block or +subroutine) by unconventional means, such as a goto, or a loop control +statement. See L<perlfunc/sort>. + +=item Identifier too long + +(F) Perl limits identifiers (names for variables, functions, etc.) to +252 characters for simple names, somewhat more for compound names (like +C<$A::B>). You've exceeded Perl's limits. Future versions of Perl are +likely to eliminate these arbitrary limitations. + +=item Illegal character %s (carriage return) + +(F) A carriage return character was found in the input. This is an +error, and not a warning, because carriage return characters can break +multi-line strings, including here documents (e.g., C<print E<lt>E<lt>EOF;>). + +=item Illegal switch in PERL5OPT: %s + +(X) The PERL5OPT environment variable may only be used to set the +following switches: B<-[DIMUdmw]>. + +=item Integer overflow in hex number + +(S) The literal hex number you have specified is too big for your +architecture. On a 32-bit architecture the largest hex literal is +0xFFFFFFFF. + +=item Integer overflow in octal number + +(S) The literal octal number you have specified is too big for your +architecture. On a 32-bit architecture the largest octal literal is +037777777777. + +=item internal error: glob failed + +(P) Something went wrong with the external program(s) used for C<glob> +and C<E<lt>*.cE<gt>>. This may mean that your csh (C shell) is +broken. If so, you should change all of the csh-related variables in +config.sh: If you have tcsh, make the variables refer to it as if it +were csh (e.g. C<full_csh='/usr/bin/tcsh'>); otherwise, make them all +empty (except that C<d_csh> should be C<'undef'>) so that Perl will +think csh is missing. In either case, after editing config.sh, run +C<./Configure -S> and rebuild Perl. + +=item Invalid conversion in %s: "%s" + +(W) Perl does not understand the given format conversion. +See L<perlfunc/sprintf>. + +=item Invalid type in pack: '%s' + +(F) The given character is not a valid pack type. See L<perlfunc/pack>. + +=item Invalid type in unpack: '%s' + +(F) The given character is not a valid unpack type. See L<perlfunc/unpack>. + +=item Name "%s::%s" used only once: possible typo + +(W) Typographical errors often show up as unique variable names. +If you had a good reason for having a unique name, then just mention +it again somehow to suppress the message (the C<use vars> pragma is +provided for just this purpose). + +=item Null picture in formline + +(F) The first argument to formline must be a valid format picture +specification. It was found to be empty, which probably means you +supplied it an uninitialized value. See L<perlform>. + +=item Offset outside string + +(F) You tried to do a read/write/send/recv operation with an offset +pointing outside the buffer. This is difficult to imagine. +The sole exception to this is that C<sysread()>ing past the buffer +will extend the buffer and zero pad the new area. + +=item Out of memory! + +(X|F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. + +The request was judged to be small, so the possibility to trap it +depends on the way Perl was compiled. By default it is not trappable. +However, if compiled for this, Perl may use the contents of C<$^M> as +an emergency pool after die()ing with this message. In this case the +error is trappable I<once>. + +=item Out of memory during request for %s + +(F) The malloc() function returned 0, indicating there was insufficient +remaining memory (or virtual memory) to satisfy the request. However, +the request was judged large enough (compile-time default is 64K), so +a possibility to shut down by trapping this error is granted. + +=item panic: frexp + +(P) The library function frexp() failed, making printf("%f") impossible. + +=item Possible attempt to put comments in qw() list + +(W) qw() lists contain items separated by whitespace; as with literal +strings, comment characters are not ignored, but are instead treated +as literal data. (You may have used different delimiters than the +exclamation marks parentheses shown here; braces are also frequently +used.) + +You probably wrote something like this: + + @list = qw( + a # a comment + b # another comment + ); + +when you should have written this: + + @list = qw( + a + b + ); + +If you really want comments, build your list the +old-fashioned way, with quotes and commas: + + @list = ( + 'a', # a comment + 'b', # another comment + ); + +=item Possible attempt to separate words with commas + +(W) qw() lists contain items separated by whitespace; therefore commas +aren't needed to separate the items. (You may have used different +delimiters than the parentheses shown here; braces are also frequently +used.) + +You probably wrote something like this: + + qw! a, b, c !; + +which puts literal commas into some of the list items. Write it without +commas if you don't want them to appear in your data: + + qw! a b c !; + +=item Scalar value @%s{%s} better written as $%s{%s} + +(W) You've used a hash slice (indicated by @) to select a single element of +a hash. Generally it's better to ask for a scalar value (indicated by $). +The difference is that C<$foo{&bar}> always behaves like a scalar, both when +assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves +like a list when you assign to it, and provides a list context to its +subscript, which can do weird things if you're expecting only one subscript. + +=item Stub found while resolving method `%s' overloading `%s' in package `%s' + +(P) Overloading resolution over @ISA tree may be broken by importing stubs. +Stubs should never be implicitely created, but explicit calls to C<can> +may break this. + +=item Too late for "B<-T>" option + +(X) The #! line (or local equivalent) in a Perl script contains the +B<-T> option, but Perl was not invoked with B<-T> in its argument +list. This is an error because, by the time Perl discovers a B<-T> in +a script, it's too late to properly taint everything from the +environment. So Perl gives up. + +=item untie attempted while %d inner references still exist + +(W) A copy of the object returned from C<tie> (or C<tied>) was still +valid when C<untie> was called. + +=item Unrecognized character %s + +(F) The Perl parser has no idea what to do with the specified character +in your Perl script (or eval). Perhaps you tried to run a compressed +script, a binary program, or a directory as a Perl program. + +=item Unsupported function fork + +(F) Your version of executable does not support forking. + +Note that under some systems, like OS/2, there may be different flavors of +Perl executables, some of which may support fork, some not. Try changing +the name you call Perl by to C<perl_>, C<perl__>, and so on. + +=item Use of "$$<digit>" to mean "${$}<digit>" is deprecated + +(D) Perl versions before 5.004 misinterpreted any type marker followed +by "$" and a digit. For example, "$$0" was incorrectly taken to mean +"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004. + +However, the developers of Perl 5.004 could not fix this bug completely, +because at least two widely-used modules depend on the old meaning of +"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the +old (broken) way inside strings; but it generates this message as a +warning. And in Perl 5.005, this special treatment will cease. + +=item Value of %s can be "0"; test with defined() + +(W) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>, +or C<readdir()> as a boolean value. Each of these constructs can return a +value of "0"; that would make the conditional expression false, which is +probably not what you intended. When using these constructs in conditional +expressions, test their values with the C<defined> operator. + +=item Variable "%s" may be unavailable + +(W) An inner (nested) I<anonymous> subroutine is inside a I<named> +subroutine, and outside that is another subroutine; and the anonymous +(innermost) subroutine is referencing a lexical variable defined in +the outermost subroutine. For example: + + sub outermost { my $a; sub middle { sub { $a } } } + +If the anonymous subroutine is called or referenced (directly or +indirectly) from the outermost subroutine, it will share the variable +as you would expect. But if the anonymous subroutine is called or +referenced when the outermost subroutine is not active, it will see +the value of the shared variable as it was before and during the +*first* call to the outermost subroutine, which is probably not what +you want. + +In these circumstances, it is usually best to make the middle +subroutine anonymous, using the C<sub {}> syntax. Perl has specific +support for shared variables in nested anonymous subroutines; a named +subroutine in between interferes with this feature. + +=item Variable "%s" will not stay shared + +(W) An inner (nested) I<named> subroutine is referencing a lexical +variable defined in an outer subroutine. + +When the inner subroutine is called, it will probably see the value of +the outer subroutine's variable as it was before and during the +*first* call to the outer subroutine; in this case, after the first +call to the outer subroutine is complete, the inner and outer +subroutines will no longer share a common value for the variable. In +other words, the variable will no longer be shared. + +Furthermore, if the outer subroutine is anonymous and references a +lexical variable outside itself, then the outer and inner subroutines +will I<never> share the given variable. + +This problem can usually be solved by making the inner subroutine +anonymous, using the C<sub {}> syntax. When inner anonymous subs that +reference variables in outer subroutines are called or referenced, +they are automatically rebound to the current values of such +variables. + +=item Warning: something's wrong + +(W) You passed warn() an empty string (the equivalent of C<warn "">) or +you called it with no args and C<$_> was empty. + +=item Ill-formed logical name |%s| in prime_env_iter + +(W) A warning peculiar to VMS. A logical name was encountered when preparing +to iterate over %ENV which violates the syntactic rules governing logical +names. Since it cannot be translated normally, it is skipped, and will not +appear in %ENV. This may be a benign occurrence, as some software packages +might directly modify logical name tables and introduce nonstandard names, +or it may indicate that a logical name table has been corrupted. + +=item Got an error from DosAllocMem + +(P) An error peculiar to OS/2. Most probably you're using an obsolete +version of Perl, and this should not happen anyway. + +=item Malformed PERLLIB_PREFIX + +(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form + + prefix1;prefix2 + +or + + prefix1 prefix2 + +with nonempty prefix1 and prefix2. If C<prefix1> is indeed a prefix +of a builtin library search path, prefix2 is substituted. The error +may appear if components are not found, or are too long. See +"PERLLIB_PREFIX" in F<README.os2>. + +=item PERL_SH_DIR too long + +(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the +C<sh>-shell in. See "PERL_SH_DIR" in F<README.os2>. + +=item Process terminated by SIG%s + +(W) This is a standard message issued by OS/2 applications, while *nix +applications die in silence. It is considered a feature of the OS/2 +port. One can easily disable this by appropriate sighandlers, see +L<perlipc/"Signals">. See also "Process terminated by SIGTERM/SIGINT" +in F<README.os2>. + +=back + +=head1 BUGS + +If you find what you think is a bug, you might check the headers of +recently posted articles in the comp.lang.perl.misc newsgroup. +There may also be information at http://www.perl.com/perl/, the Perl +Home Page. + +If you believe you have an unreported bug, please run the B<perlbug> +program included with your release. Make sure you trim your bug down +to a tiny but sufficient test case. Your bug report, along with the +output of C<perl -V>, will be sent off to <F<perlbug@perl.com>> to be +analysed by the Perl porting team. + +=head1 SEE ALSO + +The F<Changes> file for exhaustive details on what changed. + +The F<INSTALL> file for how to build Perl. This file has been +significantly updated for 5.004, so even veteran users should +look through it. + +The F<README> file for general stuff. + +The F<Copying> file for copyright information. + +=head1 HISTORY + +Constructed by Tom Christiansen, grabbing material with permission +from innumerable contributors, with kibitzing by more than a few Perl +porters. + +Last update: Wed May 14 11:14:09 EDT 1997 diff --git a/gnu/usr.bin/perl/pod/perlfaq.pod b/gnu/usr.bin/perl/pod/perlfaq.pod new file mode 100644 index 00000000000..2213a0f2f01 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq.pod @@ -0,0 +1,174 @@ +=head1 NAME + +perlfaq - frequently asked questions about Perl ($Date: 1997/04/24 22:46:06 $) + +=head1 DESCRIPTION + +This document is structured into the following sections: + +=over + +=item perlfaq: Structural overview of the FAQ. + +This document. + +=item L<perlfaq1>: General Questions About Perl + +Very general, high-level information about Perl. + +=item L<perlfaq2>: Obtaining and Learning about Perl + +Where to find source and documentation to Perl, support and training, +and related matters. + +=item L<perlfaq3>: Programming Tools + +Programmer tools and programming support. + +=item L<perlfaq4>: Data Manipulation + +Manipulating numbers, dates, strings, arrays, hashes, and +miscellaneous data issues. + +=item L<perlfaq5>: Files and Formats + +I/O and the "f" issues: filehandles, flushing, formats and footers. + +=item L<perlfaq6>: Regexps + +Pattern matching and regular expressions. + +=item L<perlfaq7>: General Perl Language Issues + +General Perl language issues that don't clearly fit into any of the +other sections. + +=item L<perlfaq8>: System Interaction + +Interprocess communication (IPC), control over the user-interface +(keyboard, screen and pointing devices). + +=item L<perlfaq9>: Networking + +Networking, the Internet, and a few on the web. + +=back + +=head2 Where to get this document + +This document is posted regularly to comp.lang.perl.announce and +several other related newsgroups. It is available in a variety of +formats from CPAN in the /CPAN/doc/FAQs/FAQ/ directory, or on the web +at http://www.perl.com/perl/faq/ . + +=head2 How to contribute to this document + +You may mail corrections, additions, and suggestions to +perlfaq-suggestions@perl.com . Mail sent to the old perlfaq alias +will merely cause the FAQ to be sent to you. + +=head2 What will happen if you mail your Perl programming problems to the authors + +Your questions will probably go unread, unless they're suggestions of +new questions to add to the FAQ, in which case they should have gone +to the perlfaq-suggestions@perl.com instead. + +You should have read section 2 of this faq. There you would have +learned that comp.lang.perl.misc is the appropriate place to go for +free advice. If your question is really important and you require a +prompt and correct answer, you should hire a consultant. + +=head1 Credits + +When I first began the Perl FAQ in the late 80s, I never realized it +would have grown to over a hundred pages, nor that Perl would ever become +so popular and widespread. This document could not have been written +without the tremendous help provided by Larry Wall and the rest of the +Perl Porters. + +=head1 Author and Copyright Information + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. + +=head2 Noncommercial Reproduction + +Permission is granted to distribute this document, in part or in full, +via electronic means or printed copy providing that (1) that all credits +and copyright notices be retained, (2) that no charges beyond reproduction +be involved, and (3) that a reasonable attempt be made to use the most +current version available. + +Furthermore, you may include this document in any distribution of the +full Perl source or binaries, in its verbatim documentation, or on a +complete dump of the CPAN archive, providing that the three stipulations +given above continue to be met. + +=head2 Commercial Reproduction + +Requests for all other distribution rights, including the incorporation +in part or in full of this text or its code into commercial products +such as but not limited to books, magazine articles, or CD-ROMs, must +be made to perlfaq-legal@perl.com. Any commercial use of any portion +of this document without prior written authorization by its authors +will be subject to appropriate action. + +=head2 Disclaimer + +This information is offered in good faith and in the hope that it may +be of use, but is not guaranteed to be correct, up to date, or suitable +for any particular purpose whatsoever. The authors accept no liability +in respect of this information or its use. + +=head1 Changes + +=over 4 + +=item 24/April/97 + +Style and whitespace changes from Chip, new question on reading one +character at a time from a terminal using POSIX from Tom. + +=item 23/April/97 + +Added http://www.oasis.leo.org/perl/ to L<perlfaq2>. Style fix to +L<perlfaq3>. Added floating point precision, fixed complex number +arithmetic, cross-references, caveat for Text::Wrap, alternative +answer for initial capitalizing, fixed incorrect regexp, added example +of Tie::IxHash to L<perlfaq4>. Added example of passing and storing +filehandles, added commify to L<perlfaq5>. Restored variable suicide, +and added mass commenting to L<perlfaq7>. Added Net::Telnet, fixed +backticks, added reader/writer pair to telnet question, added FindBin, +grouped module questions together in L<perlfaq8>. Expanded caveats +for the simple URL extractor, gave LWP example, added CGI security +question, expanded on the email address answer in L<perlfaq9>. + +=item 25/March/97 + +Added more info to the binary distribution section of L<perlfaq2>. +Added Net::Telnet to L<perlfaq6>. Fixed typos in L<perlfaq8>. Added +mail sending example to L<perlfaq9>. Added Merlyn's columns to +L<perlfaq2>. + +=item 18/March/97 + +Added the DATE to the NAME section, indicating which sections have +changed. + +Mentioned SIGPIPE and L<perlipc> in the forking open answer in +L<perlfaq8>. + +Fixed description of a regular expression in L<perlfaq4>. + +=item 17/March/97 Version + +Various typos fixed throughout. + +Added new question on Perl BNF on L<perlfaq7>. + +=item Initial Release: 11/March/97 + +This is the initial release of version 3 of the FAQ; consequently there +have been no changes since its initial release. + +=back diff --git a/gnu/usr.bin/perl/pod/perlfaq1.pod b/gnu/usr.bin/perl/pod/perlfaq1.pod new file mode 100644 index 00000000000..a9a5fd48586 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq1.pod @@ -0,0 +1,249 @@ +=head1 NAME + +perlfaq1 - General Questions About Perl ($Revision: 1.12 $, $Date: 1997/04/24 22:43:34 $) + +=head1 DESCRIPTION + +This section of the FAQ answers very general, high-level questions +about Perl. + +=head2 What is Perl? + +Perl is a high-level programming language with an eclectic heritage +written by Larry Wall and a cast of thousands. It derives from the +ubiquitous C programming language and to a lesser extent from sed, +awk, the Unix shell, and at least a dozen other tools and languages. +Perl's process, file, and text manipulation facilities make it +particularly well-suited for tasks involving quick prototyping, system +utilities, software tools, system management tasks, database access, +graphical programming, networking, and world wide web programming. +These strengths make it especially popular with system administrators +and CGI script authors, but mathematicians, geneticists, journalists, +and even managers also use Perl. Maybe you should, too. + +=head2 Who supports Perl? Who develops it? Why is it free? + +The original culture of the pre-populist Internet and the deeply-held +beliefs of Perl's author, Larry Wall, gave rise to the free and open +distribution policy of perl. Perl is supported by its users. The +core, the standard Perl library, the optional modules, and the +documentation you're reading now were all written by volunteers. See +the personal note at the end of the README file in the perl source +distribution for more details. + +In particular, the core development team (known as the Perl +Porters) are a rag-tag band of highly altruistic individuals +committed to producing better software for free than you +could hope to purchase for money. You may snoop on pending +developments via news://genetics.upenn.edu/perl.porters-gw/ and +http://www.frii.com/~gnat/perl/porters/summary.html. + +While the GNU project includes Perl in its distributions, there's no +such thing as "GNU Perl". Perl is not produced nor maintained by the +Free Software Foundation. Perl's licensing terms are also more open +than GNU software's tend to be. + +You can get commercial support of Perl if you wish, although for most +users the informal support will more than suffice. See the answer to +"Where can I buy a commercial version of perl?" for more information. + +=head2 Which version of Perl should I use? + +You should definitely use version 5. Version 4 is old, limited, and +no longer maintained; its last patch (4.036) was in 1992. The most +recent production release is 5.004. Further references to the Perl +language in this document refer to this production release unless +otherwise specified. There may be one or more official bug fixes for +5.004 by the time you read this, and also perhaps some experimental +versions on the way to the next release. + +=head2 What are perl4 and perl5? + +Perl4 and perl5 are informal names for different versions of the Perl +programming language. It's easier to say "perl5" than it is to say +"the 5(.004) release of Perl", but some people have interpreted this +to mean there's a language called "perl5", which isn't the case. +Perl5 is merely the popular name for the fifth major release (October 1994), +while perl4 was the fourth major release (March 1991). There was also a +perl1 (in January 1988), a perl2 (June 1988), and a perl3 (October 1989). + +The 5.0 release is, essentially, a complete rewrite of the perl source +code from the ground up. It has been modularized, object-oriented, +tweaked, trimmed, and optimized until it almost doesn't look like the +old code. However, the interface is mostly the same, and compatibility +with previous releases is very high. + +To avoid the "what language is perl5?" confusion, some people prefer to +simply use "perl" to refer to the latest version of perl and avoid using +"perl5" altogether. It's not really that big a deal, though. + +=head2 How stable is Perl? + +Production releases, which incorporate bug fixes and new functionality, +are widely tested before release. Since the 5.000 release, we have +averaged only about one production release per year. + +Larry and the Perl development team occasionally make changes to the +internal core of the language, but all possible efforts are made toward +backward compatibility. While not quite all perl4 scripts run flawlessly +under perl5, an update to perl should nearly never invalidate a program +written for an earlier version of perl (barring accidental bug fixes +and the rare new keyword). + +=head2 Is Perl difficult to learn? + +Perl is easy to start learning -- and easy to keep learning. It looks +like most programming languages you're likely to have had experience +with, so if you've ever written an C program, an awk script, a shell +script, or even an Excel macro, you're already part way there. + +Most tasks only require a small subset of the Perl language. One of +the guiding mottos for Perl development is "there's more than one way +to do it" (TMTOWTDI, sometimes pronounced "tim toady"). Perl's +learning curve is therefore shallow (easy to learn) and long (there's +a whole lot you can do if you really want). + +Finally, Perl is (frequently) an interpreted language. This means +that you can write your programs and test them without an intermediate +compilation step, allowing you to experiment and test/debug quickly +and easily. This ease of experimentation flattens the learning curve +even more. + +Things that make Perl easier to learn: Unix experience, almost any kind +of programming experience, an understanding of regular expressions, and +the ability to understand other people's code. If there's something you +need to do, then it's probably already been done, and a working example is +usually available for free. Don't forget the new perl modules, either. +They're discussed in Part 3 of this FAQ, along with the CPAN, which is +discussed in Part 2. + +=head2 How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl? + +Favorably in some areas, unfavorably in others. Precisely which areas +are good and bad is often a personal choice, so asking this question +on Usenet runs a strong risk of starting an unproductive Holy War. + +Probably the best thing to do is try to write equivalent code to do a +set of tasks. These languages have their own newsgroups in which you +can learn about (but hopefully not argue about) them. + +=head2 Can I do [task] in Perl? + +Perl is flexible and extensible enough for you to use on almost any +task, from one-line file-processing tasks to complex systems. For +many people, Perl serves as a great replacement for shell scripting. +For others, it serves as a convenient, high-level replacement for most +of what they'd program in low-level languages like C or C++. It's +ultimately up to you (and possibly your management ...) which tasks +you'll use Perl for and which you won't. + +If you have a library that provides an API, you can make any component +of it available as just another Perl function or variable using a Perl +extension written in C or C++ and dynamically linked into your main +perl interpreter. You can also go the other direction, and write your +main program in C or C++, and then link in some Perl code on the fly, +to create a powerful application. + +That said, there will always be small, focused, special-purpose +languages dedicated to a specific problem domain that are simply more +convenient for certain kinds of problems. Perl tries to be all things +to all people, but nothing special to anyone. Examples of specialized +languages that come to mind include prolog and matlab. + +=head2 When shouldn't I program in Perl? + +When your manager forbids it -- but do consider replacing them :-). + +Actually, one good reason is when you already have an existing +application written in another language that's all done (and done +well), or you have an application language specifically designed for a +certain task (e.g. prolog, make). + +For various reasons, Perl is probably not well-suited for real-time +embedded systems, low-level operating systems development work like +device drivers or context-switching code, complex multithreaded +shared-memory applications, or extremely large applications. You'll +notice that perl is not itself written in Perl. + +The new native-code compiler for Perl may reduce the limitations given +in the previous statement to some degree, but understand that Perl +remains fundamentally a dynamically typed language, and not a +statically typed one. You certainly won't be chastized if you don't +trust nuclear-plant or brain-surgery monitoring code to it. And +Larry will sleep easier, too -- Wall Street programs not +withstanding. :-) + +=head2 What's the difference between "perl" and "Perl"? + +One bit. Oh, you weren't talking ASCII? :-) Larry now uses "Perl" to +signify the language proper and "perl" the implementation of it, +i.e. the current interpreter. Hence Tom's quip that "Nothing but perl +can parse Perl." You may or may not choose to follow this usage. For +example, parallelism means "awk and perl" and "Python and Perl" look +ok, while "awk and Perl" and "Python and perl" do not. + +=head2 Is it a Perl program or a Perl script? + +It doesn't matter. + +In "standard terminology" a I<program> has been compiled to physical +machine code once, and can then be be run multiple times, whereas a +I<script> must be translated by a program each time it's used. Perl +programs, however, are usually neither strictly compiled nor strictly +interpreted. They can be compiled to a byte code form (something of a +Perl virtual machine) or to completely different languages, like C or +assembly language. You can't tell just by looking whether the source +is destined for a pure interpreter, a parse-tree interpreter, a byte +code interpreter, or a native-code compiler, so it's hard to give a +definitive answer here. + +=head2 What is a JAPH? + +These are the "just another perl hacker" signatures that some people +sign their postings with. About 100 of the of the earlier ones are +available from http://www.perl.com/CPAN/misc/japh . + +=head2 Where can I get a list of Larry Wall witticisms? + +Over a hundred quips by Larry, from postings of his or source code, +can be found at http://www.perl.com/CPAN/misc/lwall-quotes . + +=head2 How can I convince my sysadmin/supervisor/employees to use version (5/5.004/Perl instead of some other language)? + +If your manager or employees are wary of unsupported software, or +software which doesn't officially ship with your Operating System, you +might try to appeal to their self-interest. If programmers can be +more productive using and utilizing Perl constructs, functionality, +simplicity, and power, then the typical manager/supervisor/employee +may be persuaded. Regarding using Perl in general, it's also +sometimes helpful to point out that delivery times may be reduced +using Perl, as compared to other languages. + +If you have a project which has a bottleneck, especially in terms of +translation, or testing, Perl almost certainly will provide a viable, +and quick solution. In conjunction with any persuasion effort, you +should not fail to point out that Perl is used, quite extensively, and +with extremely reliable and valuable results, at many large computer +software and/or hardware companies throughout the world. In fact, +many Unix vendors now ship Perl by default, and support is usually +just a news-posting away, if you can't find the answer in the +I<comprehensive> documentation, including this FAQ. + +If you face reluctance to upgrading from an older version of perl, +then point out that version 4 is utterly unmaintained and unsupported +by the Perl Development Team. Another big sell for Perl5 is the large +number of modules and extensions which greatly reduce development time +for any given task. Also mention that the difference between version +4 and version 5 of Perl is like the difference between awk and C++. +(Well, ok, maybe not quite that distinct, but you get the idea.) If +you want support and a reasonable guarantee that what you're +developing will continue to work in the future, then you have to run +the supported version. That probably means running the 5.004 release, +although 5.003 isn't that bad (it's just one year and one release +behind). Several important bugs were fixed from the 5.000 through +5.002 versions, though, so try upgrading past them if possible. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. diff --git a/gnu/usr.bin/perl/pod/perlfaq2.pod b/gnu/usr.bin/perl/pod/perlfaq2.pod new file mode 100644 index 00000000000..8a954da64e4 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq2.pod @@ -0,0 +1,443 @@ +=head1 NAME + +perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.16 $, $Date: 1997/04/23 18:04:09 $) + +=head1 DESCRIPTION + +This section of the FAQ answers questions about where to find +source and documentation for Perl, support and training, and +related matters. + +=head2 What machines support Perl? Where do I get it? + +The standard release of Perl (the one maintained by the perl +development team) is distributed only in source code form. You can +find this at http://www.perl.com/CPAN/src/latest.tar.gz, which is a +gzipped archive in POSIX tar format. This source builds with no +porting whatsoever on most Unix systems (Perl's native environment), +as well as Plan 9, VMS, QNX, OS/2, and the Amiga. + +Although it's rumored that the (imminent) 5.004 release may build +on Windows NT, this is yet to be proven. Binary distributions +for 32-bit Microsoft systems and for Apple systems can be found +http://www.perl.com/CPAN/ports/ directory. Because these are not part of +the standard distribution, they may and in fact do differ from the base +Perl port in a variety of ways. You'll have to check their respective +release notes to see just what the differences are. These differences +can be either positive (e.g. extensions for the features of the particular +platform that are not supported in the source release of perl) or negative +(e.g. might be based upon a less current source release of perl). + +A useful FAQ for Win32 Perl users is +http://www.endcontsw.com/people/evangelo/Perl_for_Win32_FAQ.html + +=head2 How can I get a binary version of Perl? + +If you don't have a C compiler because for whatever reasons your +vendor did not include one with your system, the best thing to do is +grab a binary version of gcc from the net and use that to compile perl +with. CPAN only has binaries for systems that are terribly hard to +get free compilers for, not for Unix systems. + +Your first stop should be http://www.perl.com/CPAN/ports to see what +information is already available. A simple installation guide for +MS-DOS is available at http://www.cs.ruu.nl/~piet/perl5dos.html , and +similarly for Windows 3.1 at http://www.cs.ruu.nl/~piet/perlwin3.html +. + +=head2 I don't have a C compiler on my system. How can I compile perl? + +Since you don't have a C compiler, you're doomed and your vendor +should be sacrificed to the Sun gods. But that doesn't help you. + +What you need to do is get a binary version of gcc for your system +first. Consult the Usenet FAQs for your operating system for +information on where to get such a binary version. + +=head2 I copied the Perl binary from one machine to another, but scripts don't work. + +That's probably because you forgot libraries, or library paths differ. +You really should build the whole distribution on the machine it will +eventually live on, and then type C<make install>. Most other +approaches are doomed to failure. + +One simple way to check that things are in the right place is to print out +the hard-coded @INC which perl is looking for. + + perl -e 'print join("\n",@INC)' + +If this command lists any paths which don't exist on your system, then you +may need to move the appropriate libraries to these locations, or create +symlinks, aliases, or shortcuts appropriately. + +You might also want to check out L<perlfaq8/"How do I keep my own +module/library directory?">. + +=head2 I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make it work? + +Read the F<INSTALL> file, which is part of the source distribution. +It describes in detail how to cope with most idiosyncracies that the +Configure script can't work around for any given system or +architecture. + +=head2 What modules and extensions are available for Perl? What is CPAN? What does CPAN/src/... mean? + +CPAN stands for Comprehensive Perl Archive Network, a huge archive +replicated on dozens of machines all over the world. CPAN contains +source code, non-native ports, documentation, scripts, and many +third-party modules and extensions, designed for everything from +commercial database interfaces to keyboard/screen control to web +walking and CGI scripts. The master machine for CPAN is +ftp://ftp.funet.fi/pub/languages/perl/CPAN/, but you can use the +address http://www.perl.com/CPAN/CPAN.html to fetch a copy from a +"site near you". See http://www.perl.com/CPAN (without a slash at the +end) for how this process works. + +CPAN/path/... is a naming convention for files available on CPAN +sites. CPAN indicates the base directory of a CPAN mirror, and the +rest of the path is the path from that directory to the file. For +instance, if you're using ftp://ftp.funet.fi/pub/languages/perl/CPAN +as your CPAN site, the file CPAN/misc/japh file is downloadable as +ftp://ftp.funet.fi/pub/languages/perl/CPAN/misc/japh . + +Considering that there are hundreds of existing modules in the +archive, one probably exists to do nearly anything you can think of. +Current categories under CPAN/modules/by-category/ include perl core +modules; development support; operating system interfaces; networking, +devices, and interprocess communication; data type utilities; database +interfaces; user interfaces; interfaces to other languages; filenames, +file systems, and file locking; internationalization and locale; world +wide web support; server and daemon utilities; archiving and +compression; image manipulation; mail and news; control flow +utilities; filehandle and I/O; Microsoft Windows modules; and +miscellaneous modules. + +=head2 Is there an ISO or ANSI certified version of Perl? + +Certainly not. Larry expects that he'll be certified before Perl is. + +=head2 Where can I get information on Perl? + +The complete Perl documentation is available with the perl +distribution. If you have perl installed locally, you probably have +the documentation installed as well: type C<man perl> if you're on a +system resembling Unix. This will lead you to other important man +pages. If you're not on a Unix system, access to the documentation +will be different; for example, it might be only in HTML format. But +all proper perl installations have fully-accessible documentation. + +You might also try C<perldoc perl> in case your system doesn't +have a proper man command, or it's been misinstalled. If that doesn't +work, try looking in /usr/local/lib/perl5/pod for documentation. + +If all else fails, consult the CPAN/doc directory, which contains the +complete documentation in various formats, including native pod, +troff, html, and plain text. There's also a web page at +http://www.perl.com/perl/info/documentation.html that might help. + +It's also worth noting that there's a PDF version of the complete +documentation for perl available in the CPAN/authors/id/BMIDD +directory. + +Many good books have been written about Perl -- see the section below +for more details. + +=head2 What are the Perl newsgroups on USENET? Where do I post questions? + +The now defunct comp.lang.perl newsgroup has been superseded by the +following groups: + + comp.lang.perl.announce Moderated announcement group + comp.lang.perl.misc Very busy group about Perl in general + comp.lang.perl.modules Use and development of Perl modules + comp.lang.perl.tk Using Tk (and X) from Perl + + comp.infosystems.www.authoring.cgi Writing CGI scripts for the Web. + +There is also USENET gateway to the mailing list used by the crack +Perl development team (perl5-porters) at +news://genetics.upenn.edu/perl.porters-gw/ . + +=head2 Where should I post source code? + +You should post source code to whichever group is most appropriate, +but feel free to cross-post to comp.lang.perl.misc. If you want to +cross-post to alt.sources, please make sure it follows their posting +standards, including setting the Followup-To header line to NOT +include alt.sources; see their FAQ for details. + +=head2 Perl Books + +A number books on Perl and/or CGI programming are available. A few of +these are good, some are ok, but many aren't worth your money. Tom +Christiansen maintains a list of these books, some with extensive +reviews, at http://www.perl.com/perl/critiques/index.html. + +The incontestably definitive reference book on Perl, written by the +creator of Perl and his apostles, is now in its second edition and +fourth printing. + + Programming Perl (the "Camel Book"): + Authors: Larry Wall, Tom Christiansen, and Randal Schwartz + ISBN 1-56592-149-6 (English) + ISBN 4-89052-384-7 (Japanese) + (French and German translations in progress) + +Note that O'Reilly books are color-coded: turquoise (some would call +it teal) covers indicate perl5 coverage, while magenta (some would +call it pink) covers indicate perl4 only. Check the cover color +before you buy! + +What follows is a list of the books that the FAQ authors found personally +useful. Your mileage may (but, we hope, probably won't) vary. + +If you're already a hard-core systems programmer, then the Camel Book +just might suffice for you to learn Perl from. But if you're not, +check out the "Llama Book". It currently doesn't cover perl5, but the +2nd edition is nearly done and should be out by summer 97: + + Learning Perl (the Llama Book): + Author: Randal Schwartz, with intro by Larry Wall + ISBN 1-56592-042-2 (English) + ISBN 4-89502-678-1 (Japanese) + ISBN 2-84177-005-2 (French) + ISBN 3-930673-08-8 (German) + +Another stand-out book in the turquoise O'Reilly Perl line is the "Hip +Owls" book. It covers regular expressions inside and out, with quite a +bit devoted exclusively to Perl: + + Mastering Regular Expressions (the Cute Owls Book): + Author: Jeffrey Friedl + ISBN 1-56592-257-3 + +You can order any of these books from O'Reilly & Associates, +1-800-998-9938. Local/overseas is 1-707-829-0515. If you can locate +an O'Reilly order form, you can also fax to 1-707-829-0104. See +http://www.ora.com/ on the Web. + +Recommended Perl books that are not from O'Reilly are the following: + + Cross-Platform Perl, (for Unix and Windows NT) + Author: Eric F. Johnson + ISBN: 1-55851-483-X + + How to Set up and Maintain a World Wide Web Site, (2nd edition) + Author: Lincoln Stein, M.D., Ph.D. + ISBN: 0-201-63462-7 + + CGI Programming in C & Perl, + Author: Thomas Boutell + ISBN: 0-201-42219-0 + +Note that some of these address specific application areas (e.g. the +Web) and are not general-purpose programming books. + +=head2 Perl in Magazines + +The Perl Journal is the first and only magazine dedicated to Perl. +It is published (on paper, not online) quarterly by Jon Orwant +(orwant@tpj.com), editor. Subscription information is at http://tpj.com +or via email to subscriptions@tpj.com. + +Beyond this, two other magazines that frequently carry high-quality +articles on Perl are Web Techniques (see +http://www.webtechniques.com/) and Unix Review +(http://www.unixreview.com/). Randal Schwartz's Web Technique's +columns are available on the web at +http://www.stonehenge.com/merlyn/WebTechniques/ . + +=head2 Perl on the Net: FTP and WWW Access + +To get the best (and possibly cheapest) performance, pick a site from +the list below and use it to grab the complete list of mirror sites. +From there you can find the quickest site for you. Remember, the +following list is I<not> the complete list of CPAN mirrors. + + http://www.perl.com/CPAN (redirects to another mirror) + http://www.perl.org/CPAN + ftp://ftp.funet.fi/pub/languages/perl/CPAN/ + http://www.cs.ruu.nl/pub/PERL/CPAN/ + ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ + +http:/www.oasis.leo.org/perl/ has, amongst other things, source to +versions 1 through 5 of Perl. + +=head2 What mailing lists are there for perl? + +Most of the major modules (tk, CGI, libwww-perl) have their own +mailing lists. Consult the documentation that came with the module for +subscription information. The following are a list of mailing lists +related to perl itself. + +If you subscribe to a mailing list, it behooves you to know how to +unsubscribe from it. Strident pleas to the list itself to get you off +will not be favorably received. + +=over 4 + +=item MacPerl + +There is a mailing list for discussing Macintosh Perl. Contact +"mac-perl-request@iis.ee.ethz.ch". + +Also see Matthias Neeracher's (the creator and maintainer of MacPerl) +webpage at http://www.iis.ee.ethz.ch/~neeri/macintosh/perl.html for +many links to interesting MacPerl sites, and the applications/MPW +tools, precompiled. + +=item Perl5-Porters + +The core development team have a mailing list for discussing fixes and +changes to the language. Send mail to +"perl5-porters-request@perl.org" with help in the body of the message +for information on subscribing. + +=item NTPerl + +This list is used to discuss issues involving Win32 Perl 5 (Windows NT +and Win95). Subscribe by emailing ListManager@ActiveWare.com with the +message body: + + subscribe Perl-Win32-Users + +The list software, also written in perl, will automatically determine +your address, and subscribe you automatically. To unsubscribe, email +the following in the message body to the same address like so: + + unsubscribe Perl-Win32-Users + +You can also check http://www.activeware.com/ and select "Mailing Lists" +to join or leave this list. + +=item Perl-Packrats + +Discussion related to archiving of perl materials, particularly the +Comprehensive PerlArchive Network (CPAN). Subscribe by emailing +majordomo@cis.ufl.edu: + + subscribe perl-packrats + +The list software, also written in perl, will automatically determine +your address, and subscribe you automatically. To unsubscribe, simple +prepend the same command with an "un", and mail to the same address +like so: + + unsubscribe perl-packrats + +=back + +=head2 Archives of comp.lang.perl.misc + +Have you tried Deja News or Alta Vista? + +ftp.cis.ufl.edu:/pub/perl/comp.lang.perl.*/monthly has an almost +complete collection dating back to 12/89 (missing 08/91 through +12/93). They are kept as one large file for each month. + +You'll probably want more a sophisticated query and retrieval mechanism +than a file listing, preferably one that allows you to retrieve +articles using a fast-access indices, keyed on at least author, date, +subject, thread (as in "trn") and probably keywords. The best +solution the FAQ authors know of is the MH pick command, but it is +very slow to select on 18000 articles. + +If you have, or know where can be found, the missing sections, please +let perlfaq-suggestions@perl.com know. + +=head2 Perl Training + +While some large training companies offer their own courses on Perl, +you may prefer to contact individuals near and dear to the heart of +Perl development. Two well-known members of the Perl development team +who offer such things are Tom Christiansen <perl-classes@perl.com> +and Randal Schwartz <perl-training-info@stonehenge.com>, plus their +respective minions, who offer a variety of professional tutorials +and seminars on Perl. These courses include large public seminars, +private corporate training, and fly-ins to Colorado and Oregon. +See http://www.perl.com/perl/info/training.html for more details. + +=head2 Where can I buy a commercial version of Perl? + +In a sense, Perl already I<is> commercial software: It has a licence +that you can grab and carefully read to your manager. It is +distributed in releases and comes in well-defined packages. There is a +very large user community and an extensive literature. The +comp.lang.perl.* newsgroups and several of the mailing lists provide +free answers to your questions in near real-time. Perl has +traditionally been supported by Larry, dozens of software designers +and developers, and thousands of programmers, all working for free +to create a useful thing to make life better for everyone. + +However, these answers may not suffice for managers who require a +purchase order from a company whom they can sue should anything go +wrong. Or maybe they need very serious hand-holding and contractual +obligations. Shrink-wrapped CDs with perl on them are available from +several sources if that will help. + +Or you can purchase a real support contract. Although Cygnus historically +provided this service, they no longer sell support contracts for Perl. +Instead, the Paul Ingram Group will be taking up the slack through The +Perl Clinic. The following is a commercial from them: + +"Do you need professional support for Perl and/or Oraperl? Do you need +a support contract with defined levels of service? Do you want to pay +only for what you need? + +"The Paul Ingram Group has provided quality software development and +support services to some of the world's largest corporations for ten +years. We are now offering the same quality support services for Perl +at The Perl Clinic. This service is led by Tim Bunce, an active perl +porter since 1994 and well known as the author and maintainer of the +DBI, DBD::Oracle, and Oraperl modules and author/co-maintainer of The +Perl 5 Module List. We also offer Oracle users support for Perl5 +Oraperl and related modules (which Oracle is planning to ship as part +of Oracle Web Server 3). 20% of the profit from our Perl support work +will be donated to The Perl Institute." + +For more information, contact the The Perl Clinic: + + Tel: +44 1483 424424 + Fax: +44 1483 419419 + Web: http://www.perl.co.uk/ + Email: perl-support-info@perl.co.uk or Tim.Bunce@ig.co.uk + +=head2 Where do I send bug reports? + +If you are reporting a bug in the perl interpreter or the modules +shipped with perl, use the perlbug program in the perl distribution or +email your report to perlbug@perl.com. + +If you are posting a bug with a non-standard port (see the answer to +"What platforms is Perl available for?"), a binary distribution, or a +non-standard module (such as Tk, CGI, etc), then please see the +documentation that came with it to determine the correct place to post +bugs. + +Read the perlbug man page (perl5.004 or later) for more information. + +=head2 What is perl.com? perl.org? The Perl Institute? + +perl.org is the official vehicle for The Perl Institute. The motto of +TPI is "helping people help Perl help people" (or something like +that). It's a non-profit organization supporting development, +documentation, and dissemination of perl. Current directors of TPI +include Larry Wall, Tom Christiansen, and Randal Schwartz, whom you +may have heard of somewhere else around here. + +The perl.com domain is Tom Christiansen's domain. He created it as a +public service long before perl.org came about. It's the original PBS +of the Perl world, a clearinghouse for information about all things +Perlian, accepting no paid advertisements, glossy gifs, or (gasp!) +java applets on its pages. + +=head2 How do I learn about object-oriented Perl programming? + +L<perltoot> (distributed with 5.004 or later) is a good place to start. +Also, L<perlobj>, L<perlref>, and L<perlmod> are useful references, +while L<perlbot> has some excellent tips and tricks. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. diff --git a/gnu/usr.bin/perl/pod/perlfaq3.pod b/gnu/usr.bin/perl/pod/perlfaq3.pod new file mode 100644 index 00000000000..65ebafdea50 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq3.pod @@ -0,0 +1,504 @@ +=head1 NAME + +perlfaq3 - Programming Tools ($Revision: 1.22 $, $Date: 1997/04/24 22:43:42 $) + +=head1 DESCRIPTION + +This section of the FAQ answers questions related to programmer tools +and programming support. + +=head2 How do I do (anything)? + +Have you looked at CPAN (see L<perlfaq2>)? The chances are that +someone has already written a module that can solve your problem. +Have you read the appropriate man pages? Here's a brief index: + + Objects perlref, perlmod, perlobj, perltie + Data Structures perlref, perllol, perldsc + Modules perlmod, perlmodlib, perlsub + Regexps perlre, perlfunc, perlop + Moving to perl5 perltrap, perl + Linking w/C perlxstut, perlxs, perlcall, perlguts, perlembed + Various http://www.perl.com/CPAN/doc/FMTEYEWTK/index.html + (not a man-page but still useful) + +L<perltoc> provides a crude table of contents for the perl man page set. + +=head2 How can I use Perl interactively? + +The typical approach uses the Perl debugger, described in the +perldebug(1) man page, on an "empty" program, like this: + + perl -de 42 + +Now just type in any legal Perl code, and it will be immediately +evaluated. You can also examine the symbol table, get stack +backtraces, check variable values, set breakpoints, and other +operations typically found in symbolic debuggers + +=head2 Is there a Perl shell? + +In general, no. The Shell.pm module (distributed with perl) makes +perl try commands which aren't part of the Perl language as shell +commands. perlsh from the source distribution is simplistic and +uninteresting, but may still be what you want. + +=head2 How do I debug my Perl programs? + +Have you used C<-w>? + +Have you tried C<use strict>? + +Did you check the returns of each and every system call? + +Did you read L<perltrap>? + +Have you tried the Perl debugger, described in L<perldebug>? + +=head2 How do I profile my Perl programs? + +You should get the Devel::DProf module from CPAN, and also use +Benchmark.pm from the standard distribution. Benchmark lets you time +specific portions of your code, while Devel::DProf gives detailed +breakdowns of where your code spends its time. + +=head2 How do I cross-reference my Perl programs? + +The B::Xref module, shipped with the new, alpha-release Perl compiler +(not the general distribution), can be used to generate +cross-reference reports for Perl programs. + + perl -MO=Xref[,OPTIONS] foo.pl + +=head2 Is there a pretty-printer (formatter) for Perl? + +There is no program that will reformat Perl as much as indent(1) will +do for C. The complex feedback between the scanner and the parser +(this feedback is what confuses the vgrind and emacs programs) makes it +challenging at best to write a stand-alone Perl parser. + +Of course, if you simply follow the guidelines in L<perlstyle>, you +shouldn't need to reformat. + +Your editor can and should help you with source formatting. The +perl-mode for emacs can provide a remarkable amount of help with most +(but not all) code, and even less programmable editors can provide +significant assistance. + +If you are using to using vgrind program for printing out nice code to +a laser printer, you can take a stab at this using +http://www.perl.com/CPAN/doc/misc/tips/working.vgrind.entry, but the +results are not particularly satisfying for sophisticated code. + +=head2 Is there a ctags for Perl? + +There's a simple one at +http://www.perl.com/CPAN/authors/id/TOMC/scripts/ptags.gz which may do +the trick. + +=head2 Where can I get Perl macros for vi? + +For a complete version of Tom Christiansen's vi configuration file, +see ftp://ftp.perl.com/pub/vi/toms.exrc, the standard benchmark file +for vi emulators. This runs best with nvi, the current version of vi +out of Berkeley, which incidentally can be built with an embedded Perl +interpreter -- see http://www.perl.com/CPAN/src/misc . + +=head2 Where can I get perl-mode for emacs? + +Since Emacs version 19 patchlevel 22 or so, there have been both a +perl-mode.el and support for the perl debugger built in. These should +come with the standard Emacs 19 distribution. + +In the perl source directory, you'll find a directory called "emacs", +which contains a cperl-mode that color-codes keywords, provides +context-sensitive help, and other nifty things. + +Note that the perl-mode of emacs will have fits with "main'foo" +(single quote), and mess up the indentation and hilighting. You +should be using "main::foo", anyway. + +=head2 How can I use curses with Perl? + +The Curses module from CPAN provides a dynamically loadable object +module interface to a curses library. + +=head2 How can I use X or Tk with Perl? + +Tk is a completely Perl-based, object-oriented interface to the Tk +toolkit that doesn't force you to use Tcl just to get at Tk. Sx is an +interface to the Athena Widget set. Both are available from CPAN. + +=head2 How can I generate simple menus without using CGI or Tk? + +The http://www.perl.com/CPAN/authors/id/SKUNZ/perlmenu.v4.0.tar.gz +module, which is curses-based, can help with this. + +=head2 Can I dynamically load C routines into Perl? + +If your system architecture supports it, then the standard perl +on your system should also provide you with this via the +DynaLoader module. Read L<perlxstut> for details. + +=head2 What is undump? + +See the next questions. + +=head2 How can I make my Perl program run faster? + +The best way to do this is to come up with a better algorithm. +This can often make a dramatic difference. Chapter 8 in the Camel +has some efficiency tips in it you might want to look at. + +Other approaches include autoloading seldom-used Perl code. See the +AutoSplit and AutoLoader modules in the standard distribution for +that. Or you could locate the bottleneck and think about writing just +that part in C, the way we used to take bottlenecks in C code and +write them in assembler. Similar to rewriting in C is the use of +modules that have critical sections written in C (for instance, the +PDL module from CPAN). + +In some cases, it may be worth it to use the backend compiler to +produce byte code (saving compilation time) or compile into C, which +will certainly save compilation time and sometimes a small amount (but +not much) execution time. See the question about compiling your Perl +programs. + +If you're currently linking your perl executable to a shared libc.so, +you can often gain a 10-25% performance benefit by rebuilding it to +link with a static libc.a instead. This will make a bigger perl +executable, but your Perl programs (and programmers) may thank you for +it. See the F<INSTALL> file in the source distribution for more +information. + +Unsubstantiated reports allege that Perl interpreters that use sfio +outperform those that don't (for IO intensive applications). To try +this, see the F<INSTALL> file in the source distribution, especially +the "Selecting File IO mechanisms" section. + +The undump program was an old attempt to speed up your Perl program +by storing the already-compiled form to disk. This is no longer +a viable option, as it only worked on a few architectures, and +wasn't a good solution anyway. + +=head2 How can I make my Perl program take less memory? + +When it comes to time-space tradeoffs, Perl nearly always prefers to +throw memory at a problem. Scalars in Perl use more memory than +strings in C, arrays take more that, and hashes use even more. While +there's still a lot to be done, recent releases have been addressing +these issues. For example, as of 5.004, duplicate hash keys are +shared amongst all hashes using them, so require no reallocation. + +In some cases, using substr() or vec() to simulate arrays can be +highly beneficial. For example, an array of a thousand booleans will +take at least 20,000 bytes of space, but it can be turned into one +125-byte bit vector for a considerable memory savings. The standard +Tie::SubstrHash module can also help for certain types of data +structure. If you're working with specialist data structures +(matrices, for instance) modules that implement these in C may use +less memory than equivalent Perl modules. + +Another thing to try is learning whether your Perl was compiled with +the system malloc or with Perl's builtin malloc. Whichever one it +is, try using the other one and see whether this makes a difference. +Information about malloc is in the F<INSTALL> file in the source +distribution. You can find out whether you are using perl's malloc by +typing C<perl -V:usemymalloc>. + +=head2 Is it unsafe to return a pointer to local data? + +No, Perl's garbage collection system takes care of this. + + sub makeone { + my @a = ( 1 .. 10 ); + return \@a; + } + + for $i ( 1 .. 10 ) { + push @many, makeone(); + } + + print $many[4][5], "\n"; + + print "@many\n"; + +=head2 How can I free an array or hash so my program shrinks? + +You can't. Memory the system allocates to a program will never be +returned to the system. That's why long-running programs sometimes +re-exec themselves. + +However, judicious use of my() on your variables will help make sure +that they go out of scope so that Perl can free up their storage for +use in other parts of your program. (NB: my() variables also execute +about 10% faster than globals.) A global variable, of course, never +goes out of scope, so you can't get its space automatically reclaimed, +although undef()ing and/or delete()ing it will achieve the same effect. +In general, memory allocation and de-allocation isn't something you can +or should be worrying about much in Perl, but even this capability +(preallocation of data types) is in the works. + +=head2 How can I make my CGI script more efficient? + +Beyond the normal measures described to make general Perl programs +faster or smaller, a CGI program has additional issues. It may be run +several times per second. Given that each time it runs it will need +to be re-compiled and will often allocate a megabyte or more of system +memory, this can be a killer. Compiling into C B<isn't going to help +you> because the process start-up overhead is where the bottleneck is. + +There are at least two popular ways to avoid this overhead. One +solution involves running the Apache HTTP server (available from +http://www.apache.org/) with either of the mod_perl or mod_fastcgi +plugin modules. With mod_perl and the Apache::* modules (from CPAN), +httpd will run with an embedded Perl interpreter which pre-compiles +your script and then executes it within the same address space without +forking. The Apache extension also gives Perl access to the internal +server API, so modules written in Perl can do just about anything a +module written in C can. With the FCGI module (from CPAN), a Perl +executable compiled with sfio (see the F<INSTALL> file in the +distribution) and the mod_fastcgi module (available from +http://www.fastcgi.com/) each of your perl scripts becomes a permanent +CGI daemon processes. + +Both of these solutions can have far-reaching effects on your system +and on the way you write your CGI scripts, so investigate them with +care. + +=head2 How can I hide the source for my Perl program? + +Delete it. :-) Seriously, there are a number of (mostly +unsatisfactory) solutions with varying levels of "security". + +First of all, however, you I<can't> take away read permission, because +the source code has to be readable in order to be compiled and +interpreted. (That doesn't mean that a CGI script's source is +readable by people on the web, though.) So you have to leave the +permissions at the socially friendly 0755 level. + +Some people regard this as a security problem. If your program does +insecure things, and relies on people not knowing how to exploit those +insecurities, it is not secure. It is often possible for someone to +determine the insecure things and exploit them without viewing the +source. Security through obscurity, the name for hiding your bugs +instead of fixing them, is little security indeed. + +You can try using encryption via source filters (Filter::* from CPAN). +But crackers might be able to decrypt it. You can try using the byte +code compiler and interpreter described below, but crackers might be +able to de-compile it. You can try using the native-code compiler +described below, but crackers might be able to disassemble it. These +pose varying degrees of difficulty to people wanting to get at your +code, but none can definitively conceal it (this is true of every +language, not just Perl). + +If you're concerned about people profiting from your code, then the +bottom line is that nothing but a restrictive licence will give you +legal security. License your software and pepper it with threatening +statements like "This is unpublished proprietary software of XYZ Corp. +Your access to it does not give you permission to use it blah blah +blah." We are not lawyers, of course, so you should see a lawyer if +you want to be sure your licence's wording will stand up in court. + +=head2 How can I compile my Perl program into byte code or C? + +Malcolm Beattie has written a multifunction backend compiler, +available from CPAN, that can do both these things. It is as of +Feb-1997 in late alpha release, which means it's fun to play with if +you're a programmer but not really for people looking for turn-key +solutions. + +I<Please> understand that merely compiling into C does not in and of +itself guarantee that your code will run very much faster. That's +because except for lucky cases where a lot of native type inferencing +is possible, the normal Perl run time system is still present and thus +will still take just as long to run and be just as big. Most programs +save little more than compilation time, leaving execution no more than +10-30% faster. A few rare programs actually benefit significantly +(like several times faster), but this takes some tweaking of your +code. + +Malcolm will be in charge of the 5.005 release of Perl itself +to try to unify and merge his compiler and multithreading work into +the main release. + +You'll probably be astonished to learn that the current version of the +compiler generates a compiled form of your script whose executable is +just as big as the original perl executable, and then some. That's +because as currently written, all programs are prepared for a full +eval() statement. You can tremendously reduce this cost by building a +shared libperl.so library and linking against that. See the +F<INSTALL> podfile in the perl source distribution for details. If +you link your main perl binary with this, it will make it miniscule. +For example, on one author's system, /usr/bin/perl is only 11k in +size! + +=head2 How can I get '#!perl' to work on [MS-DOS,NT,...]? + +For OS/2 just use + + extproc perl -S -your_switches + +as the first line in C<*.cmd> file (C<-S> due to a bug in cmd.exe's +`extproc' handling). For DOS one should first invent a corresponding +batch file, and codify it in C<ALTERNATIVE_SHEBANG> (see the +F<INSTALL> file in the source distribution for more information). + +The Win95/NT installation, when using the Activeware port of Perl, +will modify the Registry to associate the .pl extension with the perl +interpreter. If you install another port, or (eventually) build your +own Win95/NT Perl using WinGCC, then you'll have to modify the +Registry yourself. + +Macintosh perl scripts will have the the appropriate Creator and +Type, so that double-clicking them will invoke the perl application. + +I<IMPORTANT!>: Whatever you do, PLEASE don't get frustrated, and just +throw the perl interpreter into your cgi-bin directory, in order to +get your scripts working for a web server. This is an EXTREMELY big +security risk. Take the time to figure out how to do it correctly. + +=head2 Can I write useful perl programs on the command line? + +Yes. Read L<perlrun> for more information. Some examples follow. +(These assume standard Unix shell quoting rules.) + + # sum first and last fields + perl -lane 'print $F[0] + $F[-1]' + + # identify text files + perl -le 'for(@ARGV) {print if -f && -T _}' * + + # remove comments from C program + perl -0777 -pe 's{/\*.*?\*/}{}gs' foo.c + + # make file a month younger than today, defeating reaper daemons + perl -e '$X=24*60*60; utime(time(),time() + 30 * $X,@ARGV)' * + + # find first unused uid + perl -le '$i++ while getpwuid($i); print $i' + + # display reasonable manpath + echo $PATH | perl -nl -072 -e ' + s![^/+]*$!man!&&-d&&!$s{$_}++&&push@m,$_;END{print"@m"}' + +Ok, the last one was actually an obfuscated perl entry. :-) + +=head2 Why don't perl one-liners work on my DOS/Mac/VMS system? + +The problem is usually that the command interpreters on those systems +have rather different ideas about quoting than the Unix shells under +which the one-liners were created. On some systems, you may have to +change single-quotes to double ones, which you must I<NOT> do on Unix +or Plan9 systems. You might also have to change a single % to a %%. + +For example: + + # Unix + perl -e 'print "Hello world\n"' + + # DOS, etc. + perl -e "print \"Hello world\n\"" + + # Mac + print "Hello world\n" + (then Run "Myscript" or Shift-Command-R) + + # VMS + perl -e "print ""Hello world\n""" + +The problem is that none of this is reliable: it depends on the command +interpreter. Under Unix, the first two often work. Under DOS, it's +entirely possible neither works. If 4DOS was the command shell, I'd +probably have better luck like this: + + perl -e "print <Ctrl-x>"Hello world\n<Ctrl-x>"" + +Under the Mac, it depends which environment you are using. The MacPerl +shell, or MPW, is much like Unix shells in its support for several +quoting variants, except that it makes free use of the Mac's non-ASCII +characters as control characters. + +I'm afraid that there is no general solution to all of this. It is a +mess, pure and simple. + +[Some of this answer was contributed by Kenneth Albanowski.] + +=head2 Where can I learn about CGI or Web programming in Perl? + +For modules, get the CGI or LWP modules from CPAN. For textbooks, +see the two especially dedicated to web stuff in the question on +books. For problems and questions related to the web, like "Why +do I get 500 Errors" or "Why doesn't it run from the browser right +when it runs fine on the command line", see these sources: + + The Idiot's Guide to Solving Perl/CGI Problems, by Tom Christiansen + http://www.perl.com/perl/faq/idiots-guide.html + + Frequently Asked Questions about CGI Programming, by Nick Kew + ftp://rtfm.mit.edu/pub/usenet/news.answers/www/cgi-faq + http://www3.pair.com/webthing/docs/cgi/faqs/cgifaq.shtml + + Perl/CGI programming FAQ, by Shishir Gundavaram and Tom Christiansen + http://www.perl.com/perl/faq/perl-cgi-faq.html + + The WWW Security FAQ, by Lincoln Stein + http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html + + World Wide Web FAQ, by Thomas Boutell + http://www.boutell.com/faq/ + +=head2 Where can I learn about object-oriented Perl programming? + +L<perltoot> is a good place to start, and you can use L<perlobj> and +L<perlbot> for reference. Perltoot didn't come out until the 5.004 +release, but you can get a copy (in pod, html, or postscript) from +http://www.perl.com/CPAN/doc/FMTEYEWTK/ . + +=head2 Where can I learn about linking C with Perl? [h2xs, xsubpp] + +If you want to call C from Perl, start with L<perlxstut>, +moving on to L<perlxs>, L<xsubpp>, and L<perlguts>. If you want to +call Perl from C, then read L<perlembed>, L<perlcall>, and +L<perlguts>. Don't forget that you can learn a lot from looking at +how the authors of existing extension modules wrote their code and +solved their problems. + +=head2 I've read perlembed, perlguts, etc., but I can't embed perl in +my C program, what am I doing wrong? + +Download the ExtUtils::Embed kit from CPAN and run `make test'. If +the tests pass, read the pods again and again and again. If they +fail, see L<perlbug> and send a bugreport with the output of +C<make test TEST_VERBOSE=1> along with C<perl -V>. + +=head2 When I tried to run my script, I got this message. What does it +mean? + +L<perldiag> has a complete list of perl's error messages and warnings, +with explanatory text. You can also use the splain program (distributed +with perl) to explain the error messages: + + perl program 2>diag.out + splain [-v] [-p] diag.out + +or change your program to explain the messages for you: + + use diagnostics; + +or + + use diagnostics -verbose; + +=head2 What's MakeMaker? + +This module (part of the standard perl distribution) is designed to +write a Makefile for an extension module from a Makefile.PL. For more +information, see L<ExtUtils::MakeMaker>. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. + diff --git a/gnu/usr.bin/perl/pod/perlfaq4.pod b/gnu/usr.bin/perl/pod/perlfaq4.pod new file mode 100644 index 00000000000..a5b505c4a7a --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq4.pod @@ -0,0 +1,1101 @@ +=head1 NAME + +perlfaq4 - Data Manipulation ($Revision: 1.19 $, $Date: 1997/04/24 22:43:57 $) + +=head1 DESCRIPTION + +The section of the FAQ answers question related to the manipulation +of data as numbers, dates, strings, arrays, hashes, and miscellaneous +data issues. + +=head1 Data: Numbers + +=head2 Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)? + +Internally, your computer represents floating-point numbers in binary. +Floating-point numbers read in from a file, or appearing as literals +in your program, are converted from their decimal floating-point +representation (eg, 19.95) to the internal binary representation. + +However, 19.95 can't be precisely represented as a binary +floating-point number, just like 1/3 can't be exactly represented as a +decimal floating-point number. The computer's binary representation +of 19.95, therefore, isn't exactly 19.95. + +When a floating-point number gets printed, the binary floating-point +representation is converted back to decimal. These decimal numbers +are displayed in either the format you specify with printf(), or the +current output format for numbers (see L<perlvar/"$#"> if you use +print. C<$#> has a different default value in Perl5 than it did in +Perl4. Changing C<$#> yourself is deprecated. + +This affects B<all> computer languages that represent decimal +floating-point numbers in binary, not just Perl. Perl provides +arbitrary-precision decimal numbers with the Math::BigFloat module +(part of the standard Perl distribution), but mathematical operations +are consequently slower. + +To get rid of the superfluous digits, just use a format (eg, +C<printf("%.2f", 19.95)>) to get the required precision. + +=head2 Why isn't my octal data interpreted correctly? + +Perl only understands octal and hex numbers as such when they occur +as literals in your program. If they are read in from somewhere and +assigned, no automatic conversion takes place. You must explicitly +use oct() or hex() if you want the values converted. oct() interprets +both hex ("0x350") numbers and octal ones ("0350" or even without the +leading "0", like "377"), while hex() only converts hexadecimal ones, +with or without a leading "0x", like "0x255", "3A", "ff", or "deadbeef". + +This problem shows up most often when people try using chmod(), mkdir(), +umask(), or sysopen(), which all want permissions in octal. + + chmod(644, $file); # WRONG -- perl -w catches this + chmod(0644, $file); # right + +=head2 Does perl have a round function? What about ceil() and floor()? +Trig functions? + +For rounding to a certain number of digits, sprintf() or printf() is +usually the easiest route. + +The POSIX module (part of the standard perl distribution) implements +ceil(), floor(), and a number of other mathematical and trigonometric +functions. + +In 5.000 to 5.003 Perls, trigonometry was done in the Math::Complex +module. With 5.004, the Math::Trig module (part of the standard perl +distribution) implements the trigonometric functions. Internally it +uses the Math::Complex module and some functions can break out from +the real axis into the complex plane, for example the inverse sine of +2. + +Rounding in financial applications can have serious implications, and +the rounding method used should be specified precisely. In these +cases, it probably pays not to trust whichever system rounding is +being used by Perl, but to instead implement the rounding function you +need yourself. + +=head2 How do I convert bits into ints? + +To turn a string of 1s and 0s like '10110110' into a scalar containing +its binary value, use the pack() function (documented in +L<perlfunc/"pack">): + + $decimal = pack('B8', '10110110'); + +Here's an example of going the other way: + + $binary_string = join('', unpack('B*', "\x29")); + +=head2 How do I multiply matrices? + +Use the Math::Matrix or Math::MatrixReal modules (available from CPAN) +or the PDL extension (also available from CPAN). + +=head2 How do I perform an operation on a series of integers? + +To call a function on each element in an array, and collect the +results, use: + + @results = map { my_func($_) } @array; + +For example: + + @triple = map { 3 * $_ } @single; + +To call a function on each element of an array, but ignore the +results: + + foreach $iterator (@array) { + &my_func($iterator); + } + +To call a function on each integer in a (small) range, you B<can> use: + + @results = map { &my_func($_) } (5 .. 25); + +but you should be aware that the C<..> operator creates an array of +all integers in the range. This can take a lot of memory for large +ranges. Instead use: + + @results = (); + for ($i=5; $i < 500_005; $i++) { + push(@results, &my_func($i)); + } + +=head2 How can I output Roman numerals? + +Get the http://www.perl.com/CPAN/modules/by-module/Roman module. + +=head2 Why aren't my random numbers random? + +The short explanation is that you're getting pseudorandom numbers, not +random ones, because that's how these things work. A longer +explanation is available on +http://www.perl.com/CPAN/doc/FMTEYEWTK/random, courtesy of Tom +Phoenix. + +You should also check out the Math::TrulyRandom module from CPAN. + +=head1 Data: Dates + +=head2 How do I find the week-of-the-year/day-of-the-year? + +The day of the year is in the array returned by localtime() (see +L<perlfunc/"localtime">): + + $day_of_year = (localtime(time()))[7]; + +or more legibly (in 5.004 or higher): + + use Time::localtime; + $day_of_year = localtime(time())->yday; + +You can find the week of the year by dividing this by 7: + + $week_of_year = int($day_of_year / 7); + +Of course, this believes that weeks start at zero. + +=head2 How can I compare two date strings? + +Use the Date::Manip or Date::DateCalc modules from CPAN. + +=head2 How can I take a string and turn it into epoch seconds? + +If it's a regular enough string that it always has the same format, +you can split it up and pass the parts to timelocal in the standard +Time::Local module. Otherwise, you should look into one of the +Date modules from CPAN. + +=head2 How can I find the Julian Day? + +Neither Date::Manip nor Date::DateCalc deal with Julian days. +Instead, there is an example of Julian date calculation in +http://www.perl.com/CPAN/authors/David_Muir_Sharnoff/modules/Time/JulianDay.pm.gz, +which should help. + +=head2 Does Perl have a year 2000 problem? + +Not unless you use Perl to create one. The date and time functions +supplied with perl (gmtime and localtime) supply adequate information +to determine the year well beyond 2000 (2038 is when trouble strikes). +The year returned by these functions when used in an array context is +the year minus 1900. For years between 1910 and 1999 this I<happens> +to be a 2-digit decimal number. To avoid the year 2000 problem simply +do not treat the year as a 2-digit number. It isn't. + +When gmtime() and localtime() are used in a scalar context they return +a timestamp string that contains a fully-expanded year. For example, +C<$timestamp = gmtime(1005613200)> sets $timestamp to "Tue Nov 13 01:00:00 +2001". There's no year 2000 problem here. + +=head1 Data: Strings + +=head2 How do I validate input? + +The answer to this question is usually a regular expression, perhaps +with auxiliary logic. See the more specific questions (numbers, email +addresses, etc.) for details. + +=head2 How do I unescape a string? + +It depends just what you mean by "escape". URL escapes are dealt with +in L<perlfaq9>. Shell escapes with the backslash (\) +character are removed with: + + s/\\(.)/$1/g; + +Note that this won't expand \n or \t or any other special escapes. + +=head2 How do I remove consecutive pairs of characters? + +To turn "abbcccd" into "abccd": + + s/(.)\1/$1/g; + +=head2 How do I expand function calls in a string? + +This is documented in L<perlref>. In general, this is fraught with +quoting and readability problems, but it is possible. To interpolate +a subroutine call (in a list context) into a string: + + print "My sub returned @{[mysub(1,2,3)]} that time.\n"; + +If you prefer scalar context, similar chicanery is also useful for +arbitrary expressions: + + print "That yields ${\($n + 5)} widgets\n"; + +See also "How can I expand variables in text strings?" in this section +of the FAQ. + +=head2 How do I find matching/nesting anything? + +This isn't something that can be tackled in one regular expression, no +matter how complicated. To find something between two single characters, +a pattern like C</x([^x]*)x/> will get the intervening bits in $1. For +multiple ones, then something more like C</alpha(.*?)omega/> would +be needed. But none of these deals with nested patterns, nor can they. +For that you'll have to write a parser. + +=head2 How do I reverse a string? + +Use reverse() in a scalar context, as documented in +L<perlfunc/reverse>. + + $reversed = reverse $string; + +=head2 How do I expand tabs in a string? + +You can do it the old-fashioned way: + + 1 while $string =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e; + +Or you can just use the Text::Tabs module (part of the standard perl +distribution). + + use Text::Tabs; + @expanded_lines = expand(@lines_with_tabs); + +=head2 How do I reformat a paragraph? + +Use Text::Wrap (part of the standard perl distribution): + + use Text::Wrap; + print wrap("\t", ' ', @paragraphs); + +The paragraphs you give to Text::Wrap may not contain embedded +newlines. Text::Wrap doesn't justify the lines (flush-right). + +=head2 How can I access/change the first N letters of a string? + +There are many ways. If you just want to grab a copy, use +substr: + + $first_byte = substr($a, 0, 1); + +If you want to modify part of a string, the simplest way is often to +use substr() as an lvalue: + + substr($a, 0, 3) = "Tom"; + +Although those with a regexp kind of thought process will likely prefer + + $a =~ s/^.../Tom/; + +=head2 How do I change the Nth occurrence of something? + +You have to keep track. For example, let's say you want +to change the fifth occurrence of "whoever" or "whomever" +into "whosoever" or "whomsoever", case insensitively. + + $count = 0; + s{((whom?)ever)}{ + ++$count == 5 # is it the 5th? + ? "${2}soever" # yes, swap + : $1 # renege and leave it there + }igex; + +=head2 How can I count the number of occurrences of a substring within a string? + +There are a number of ways, with varying efficiency: If you want a +count of a certain single character (X) within a string, you can use the +C<tr///> function like so: + + $string = "ThisXlineXhasXsomeXx'sXinXit": + $count = ($string =~ tr/X//); + print "There are $count X charcters in the string"; + +This is fine if you are just looking for a single character. However, +if you are trying to count multiple character substrings within a +larger string, C<tr///> won't work. What you can do is wrap a while() +loop around a global pattern match. For example, let's count negative +integers: + + $string = "-9 55 48 -2 23 -76 4 14 -44"; + while ($string =~ /-\d+/g) { $count++ } + print "There are $count negative numbers in the string"; + +=head2 How do I capitalize all the words on one line? + +To make the first letter of each word upper case: + + $line =~ s/\b(\w)/\U$1/g; + +This has the strange effect of turning "C<don't do it>" into "C<Don'T +Do It>". Sometimes you might want this, instead (Suggested by Brian +Foy E<lt>comdog@computerdog.comE<gt>): + + $string =~ s/ ( + (^\w) #at the beginning of the line + | # or + (\s\w) #preceded by whitespace + ) + /\U$1/xg; + $string =~ /([\w']+)/\u\L$1/g; + +To make the whole line upper case: + + $line = uc($line); + +To force each word to be lower case, with the first letter upper case: + + $line =~ s/(\w+)/\u\L$1/g; + +=head2 How can I split a [character] delimited string except when inside +[character]? (Comma-separated files) + +Take the example case of trying to split a string that is comma-separated +into its different fields. (We'll pretend you said comma-separated, not +comma-delimited, which is different and almost never what you mean.) You +can't use C<split(/,/)> because you shouldn't split if the comma is inside +quotes. For example, take a data line like this: + + SAR001,"","Cimetrix, Inc","Bob Smith","CAM",N,8,1,0,7,"Error, Core Dumped" + +Due to the restriction of the quotes, this is a fairly complex +problem. Thankfully, we have Jeffrey Friedl, author of a highly +recommended book on regular expressions, to handle these for us. He +suggests (assuming your string is contained in $text): + + @new = (); + push(@new, $+) while $text =~ m{ + "([^\"\\]*(?:\\.[^\"\\]*)*)",? # groups the phrase inside the quotes + | ([^,]+),? + | , + }gx; + push(@new, undef) if substr($text,-1,1) eq ','; + +If you want to represent quotation marks inside a +quotation-mark-delimited field, escape them with backslashes (eg, +C<"like \"this\"">. Unescaping them is a task addressed earlier in +this section. + +Alternatively, the Text::ParseWords module (part of the standard perl +distribution) lets you say: + + use Text::ParseWords; + @new = quotewords(",", 0, $text); + +=head2 How do I strip blank space from the beginning/end of a string? + +The simplest approach, albeit not the fastest, is probably like this: + + $string =~ s/^\s*(.*?)\s*$/$1/; + +It would be faster to do this in two steps: + + $string =~ s/^\s+//; + $string =~ s/\s+$//; + +Or more nicely written as: + + for ($string) { + s/^\s+//; + s/\s+$//; + } + +=head2 How do I extract selected columns from a string? + +Use substr() or unpack(), both documented in L<perlfunc>. + +=head2 How do I find the soundex value of a string? + +Use the standard Text::Soundex module distributed with perl. + +=head2 How can I expand variables in text strings? + +Let's assume that you have a string like: + + $text = 'this has a $foo in it and a $bar'; + $text =~ s/\$(\w+)/${$1}/g; + +Before version 5 of perl, this had to be done with a double-eval +substitution: + + $text =~ s/(\$\w+)/$1/eeg; + +Which is bizarre enough that you'll probably actually need an EEG +afterwards. :-) + +See also "How do I expand function calls in a string?" in this section +of the FAQ. + +=head2 What's wrong with always quoting "$vars"? + +The problem is that those double-quotes force stringification, +coercing numbers and references into strings, even when you +don't want them to be. + +If you get used to writing odd things like these: + + print "$var"; # BAD + $new = "$old"; # BAD + somefunc("$var"); # BAD + +You'll be in trouble. Those should (in 99.8% of the cases) be +the simpler and more direct: + + print $var; + $new = $old; + somefunc($var); + +Otherwise, besides slowing you down, you're going to break code when +the thing in the scalar is actually neither a string nor a number, but +a reference: + + func(\@array); + sub func { + my $aref = shift; + my $oref = "$aref"; # WRONG + } + +You can also get into subtle problems on those few operations in Perl +that actually do care about the difference between a string and a +number, such as the magical C<++> autoincrement operator or the +syscall() function. + +=head2 Why don't my <<HERE documents work? + +Check for these three things: + +=over 4 + +=item 1. There must be no space after the << part. + +=item 2. There (probably) should be a semicolon at the end. + +=item 3. You can't (easily) have any space in front of the tag. + +=back + +=head1 Data: Arrays + +=head2 What is the difference between $array[1] and @array[1]? + +The former is a scalar value, the latter an array slice, which makes +it a list with one (scalar) value. You should use $ when you want a +scalar value (most of the time) and @ when you want a list with one +scalar value in it (very, very rarely; nearly never, in fact). + +Sometimes it doesn't make a difference, but sometimes it does. +For example, compare: + + $good[0] = `some program that outputs several lines`; + +with + + @bad[0] = `same program that outputs several lines`; + +The B<-w> flag will warn you about these matters. + +=head2 How can I extract just the unique elements of an array? + +There are several possible ways, depending on whether the array is +ordered and whether you wish to preserve the ordering. + +=over 4 + +=item a) If @in is sorted, and you want @out to be sorted: + + $prev = 'nonesuch'; + @out = grep($_ ne $prev && ($prev = $_), @in); + +This is nice in that it doesn't use much extra memory, +simulating uniq(1)'s behavior of removing only adjacent +duplicates. + +=item b) If you don't know whether @in is sorted: + + undef %saw; + @out = grep(!$saw{$_}++, @in); + +=item c) Like (b), but @in contains only small integers: + + @out = grep(!$saw[$_]++, @in); + +=item d) A way to do (b) without any loops or greps: + + undef %saw; + @saw{@in} = (); + @out = sort keys %saw; # remove sort if undesired + +=item e) Like (d), but @in contains only small positive integers: + + undef @ary; + @ary[@in] = @in; + @out = @ary; + +=back + +=head2 How can I tell whether an array contains a certain element? + +There are several ways to approach this. If you are going to make +this query many times and the values are arbitrary strings, the +fastest way is probably to invert the original array and keep an +associative array lying about whose keys are the first array's values. + + @blues = qw/azure cerulean teal turquoise lapis-lazuli/; + undef %is_blue; + for (@blues) { $is_blue{$_} = 1 } + +Now you can check whether $is_blue{$some_color}. It might have been a +good idea to keep the blues all in a hash in the first place. + +If the values are all small integers, you could use a simple indexed +array. This kind of an array will take up less space: + + @primes = (2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31); + undef @is_tiny_prime; + for (@primes) { $is_tiny_prime[$_] = 1; } + +Now you check whether $is_tiny_prime[$some_number]. + +If the values in question are integers instead of strings, you can save +quite a lot of space by using bit strings instead: + + @articles = ( 1..10, 150..2000, 2017 ); + undef $read; + grep (vec($read,$_,1) = 1, @articles); + +Now check whether C<vec($read,$n,1)> is true for some C<$n>. + +Please do not use + + $is_there = grep $_ eq $whatever, @array; + +or worse yet + + $is_there = grep /$whatever/, @array; + +These are slow (checks every element even if the first matches), +inefficient (same reason), and potentially buggy (what if there are +regexp characters in $whatever?). + +=head2 How do I compute the difference of two arrays? How do I compute the intersection of two arrays? + +Use a hash. Here's code to do both and more. It assumes that +each element is unique in a given array: + + @union = @intersection = @difference = (); + %count = (); + foreach $element (@array1, @array2) { $count{$element}++ } + foreach $element (keys %count) { + push @union, $element; + push @{ $count{$element} > 1 ? \@intersection : \@difference }, $element; + } + +=head2 How do I find the first array element for which a condition is true? + +You can use this if you care about the index: + + for ($i=0; $i < @array; $i++) { + if ($array[$i] eq "Waldo") { + $found_index = $i; + last; + } + } + +Now C<$found_index> has what you want. + +=head2 How do I handle linked lists? + +In general, you usually don't need a linked list in Perl, since with +regular arrays, you can push and pop or shift and unshift at either end, +or you can use splice to add and/or remove arbitrary number of elements +at arbitrary points. + +If you really, really wanted, you could use structures as described in +L<perldsc> or L<perltoot> and do just what the algorithm book tells you +to do. + +=head2 How do I handle circular lists? + +Circular lists could be handled in the traditional fashion with linked +lists, or you could just do something like this with an array: + + unshift(@array, pop(@array)); # the last shall be first + push(@array, shift(@array)); # and vice versa + +=head2 How do I shuffle an array randomly? + +Here's a shuffling algorithm which works its way through the list, +randomly picking another element to swap the current element with: + + srand; + @new = (); + @old = 1 .. 10; # just a demo + while (@old) { + push(@new, splice(@old, rand @old, 1)); + } + +For large arrays, this avoids a lot of the reshuffling: + + srand; + @new = (); + @old = 1 .. 10000; # just a demo + for( @old ){ + my $r = rand @new+1; + push(@new,$new[$r]); + $new[$r] = $_; + } + +=head2 How do I process/modify each element of an array? + +Use C<for>/C<foreach>: + + for (@lines) { + s/foo/bar/; + tr[a-z][A-Z]; + } + +Here's another; let's compute spherical volumes: + + for (@radii) { + $_ **= 3; + $_ *= (4/3) * 3.14159; # this will be constant folded + } + +=head2 How do I select a random element from an array? + +Use the rand() function (see L<perlfunc/rand>): + + srand; # not needed for 5.004 and later + $index = rand @array; + $element = $array[$index]; + +=head2 How do I permute N elements of a list? + +Here's a little program that generates all permutations +of all the words on each line of input. The algorithm embodied +in the permut() function should work on any list: + + #!/usr/bin/perl -n + # permute - tchrist@perl.com + permut([split], []); + sub permut { + my @head = @{ $_[0] }; + my @tail = @{ $_[1] }; + unless (@head) { + # stop recursing when there are no elements in the head + print "@tail\n"; + } else { + # for all elements in @head, move one from @head to @tail + # and call permut() on the new @head and @tail + my(@newhead,@newtail,$i); + foreach $i (0 .. $#head) { + @newhead = @head; + @newtail = @tail; + unshift(@newtail, splice(@newhead, $i, 1)); + permut([@newhead], [@newtail]); + } + } + } + +=head2 How do I sort an array by (anything)? + +Supply a comparison function to sort() (described in L<perlfunc/sort>): + + @list = sort { $a <=> $b } @list; + +The default sort function is cmp, string comparison, which would +sort C<(1, 2, 10)> into C<(1, 10, 2)>. C<E<lt>=E<gt>>, used above, is +the numerical comparison operator. + +If you have a complicated function needed to pull out the part you +want to sort on, then don't do it inside the sort function. Pull it +out first, because the sort BLOCK can be called many times for the +same element. Here's an example of how to pull out the first word +after the first number on each item, and then sort those words +case-insensitively. + + @idx = (); + for (@data) { + ($item) = /\d+\s*(\S+)/; + push @idx, uc($item); + } + @sorted = @data[ sort { $idx[$a] cmp $idx[$b] } 0 .. $#idx ]; + +Which could also be written this way, using a trick +that's come to be known as the Schwartzian Transform: + + @sorted = map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [ $_, uc((/\d+\s*(\S+)/ )[0] ] } @data; + +If you need to sort on several fields, the following paradigm is useful. + + @sorted = sort { field1($a) <=> field1($b) || + field2($a) cmp field2($b) || + field3($a) cmp field3($b) + } @data; + +This can be conveniently combined with precalculation of keys as given +above. + +See http://www.perl.com/CPAN/doc/FMTEYEWTK/sort.html for more about +this approach. + +See also the question below on sorting hashes. + +=head2 How do I manipulate arrays of bits? + +Use pack() and unpack(), or else vec() and the bitwise operations. + +For example, this sets $vec to have bit N set if $ints[N] was set: + + $vec = ''; + foreach(@ints) { vec($vec,$_,1) = 1 } + +And here's how, given a vector in $vec, you can +get those bits into your @ints array: + + sub bitvec_to_list { + my $vec = shift; + my @ints; + # Find null-byte density then select best algorithm + if ($vec =~ tr/\0// / length $vec > 0.95) { + use integer; + my $i; + # This method is faster with mostly null-bytes + while($vec =~ /[^\0]/g ) { + $i = -9 + 8 * pos $vec; + push @ints, $i if vec($vec, ++$i, 1); + push @ints, $i if vec($vec, ++$i, 1); + push @ints, $i if vec($vec, ++$i, 1); + push @ints, $i if vec($vec, ++$i, 1); + push @ints, $i if vec($vec, ++$i, 1); + push @ints, $i if vec($vec, ++$i, 1); + push @ints, $i if vec($vec, ++$i, 1); + push @ints, $i if vec($vec, ++$i, 1); + } + } else { + # This method is a fast general algorithm + use integer; + my $bits = unpack "b*", $vec; + push @ints, 0 if $bits =~ s/^(\d)// && $1; + push @ints, pos $bits while($bits =~ /1/g); + } + return \@ints; + } + +This method gets faster the more sparse the bit vector is. +(Courtesy of Tim Bunce and Winfried Koenig.) + +=head2 Why does defined() return true on empty arrays and hashes? + +See L<perlfunc/defined> in the 5.004 release or later of Perl. + +=head1 Data: Hashes (Associative Arrays) + +=head2 How do I process an entire hash? + +Use the each() function (see L<perlfunc/each>) if you don't care +whether it's sorted: + + while (($key,$value) = each %hash) { + print "$key = $value\n"; + } + +If you want it sorted, you'll have to use foreach() on the result of +sorting the keys as shown in an earlier question. + +=head2 What happens if I add or remove keys from a hash while iterating over it? + +Don't do that. + +=head2 How do I look up a hash element by value? + +Create a reverse hash: + + %by_value = reverse %by_key; + $key = $by_value{$value}; + +That's not particularly efficient. It would be more space-efficient +to use: + + while (($key, $value) = each %by_key) { + $by_value{$value} = $key; + } + +If your hash could have repeated values, the methods above will only +find one of the associated keys. This may or may not worry you. + +=head2 How can I know how many entries are in a hash? + +If you mean how many keys, then all you have to do is +take the scalar sense of the keys() function: + + $num_keys = scalar keys %hash; + +In void context it just resets the iterator, which is faster +for tied hashes. + +=head2 How do I sort a hash (optionally by value instead of key)? + +Internally, hashes are stored in a way that prevents you from imposing +an order on key-value pairs. Instead, you have to sort a list of the +keys or values: + + @keys = sort keys %hash; # sorted by key + @keys = sort { + $hash{$a} cmp $hash{$b} + } keys %hash; # and by value + +Here we'll do a reverse numeric sort by value, and if two keys are +identical, sort by length of key, and if that fails, by straight ASCII +comparison of the keys (well, possibly modified by your locale -- see +L<perllocale>). + + @keys = sort { + $hash{$b} <=> $hash{$a} + || + length($b) <=> length($a) + || + $a cmp $b + } keys %hash; + +=head2 How can I always keep my hash sorted? + +You can look into using the DB_File module and tie() using the +$DB_BTREE hash bindings as documented in L<DB_File/"In Memory Databases">. + +=head2 What's the difference between "delete" and "undef" with hashes? + +Hashes are pairs of scalars: the first is the key, the second is the +value. The key will be coerced to a string, although the value can be +any kind of scalar: string, number, or reference. If a key C<$key> is +present in the array, C<exists($key)> will return true. The value for +a given key can be C<undef>, in which case C<$array{$key}> will be +C<undef> while C<$exists{$key}> will return true. This corresponds to +(C<$key>, C<undef>) being in the hash. + +Pictures help... here's the C<%ary> table: + + keys values + +------+------+ + | a | 3 | + | x | 7 | + | d | 0 | + | e | 2 | + +------+------+ + +And these conditions hold + + $ary{'a'} is true + $ary{'d'} is false + defined $ary{'d'} is true + defined $ary{'a'} is true + exists $ary{'a'} is true (perl5 only) + grep ($_ eq 'a', keys %ary) is true + +If you now say + + undef $ary{'a'} + +your table now reads: + + + keys values + +------+------+ + | a | undef| + | x | 7 | + | d | 0 | + | e | 2 | + +------+------+ + +and these conditions now hold; changes in caps: + + $ary{'a'} is FALSE + $ary{'d'} is false + defined $ary{'d'} is true + defined $ary{'a'} is FALSE + exists $ary{'a'} is true (perl5 only) + grep ($_ eq 'a', keys %ary) is true + +Notice the last two: you have an undef value, but a defined key! + +Now, consider this: + + delete $ary{'a'} + +your table now reads: + + keys values + +------+------+ + | x | 7 | + | d | 0 | + | e | 2 | + +------+------+ + +and these conditions now hold; changes in caps: + + $ary{'a'} is false + $ary{'d'} is false + defined $ary{'d'} is true + defined $ary{'a'} is false + exists $ary{'a'} is FALSE (perl5 only) + grep ($_ eq 'a', keys %ary) is FALSE + +See, the whole entry is gone! + +=head2 Why don't my tied hashes make the defined/exists distinction? + +They may or may not implement the EXISTS() and DEFINED() methods +differently. For example, there isn't the concept of undef with hashes +that are tied to DBM* files. This means the true/false tables above +will give different results when used on such a hash. It also means +that exists and defined do the same thing with a DBM* file, and what +they end up doing is not what they do with ordinary hashes. + +=head2 How do I reset an each() operation part-way through? + +Using C<keys %hash> in a scalar context returns the number of keys in +the hash I<and> resets the iterator associated with the hash. You may +need to do this if you use C<last> to exit a loop early so that when you +re-enter it, the hash iterator has been reset. + +=head2 How can I get the unique keys from two hashes? + +First you extract the keys from the hashes into arrays, and then solve +the uniquifying the array problem described above. For example: + + %seen = (); + for $element (keys(%foo), keys(%bar)) { + $seen{$element}++; + } + @uniq = keys %seen; + +Or more succinctly: + + @uniq = keys %{{%foo,%bar}}; + +Or if you really want to save space: + + %seen = (); + while (defined ($key = each %foo)) { + $seen{$key}++; + } + while (defined ($key = each %bar)) { + $seen{$key}++; + } + @uniq = keys %seen; + +=head2 How can I store a multidimensional array in a DBM file? + +Either stringify the structure yourself (no fun), or else +get the MLDBM (which uses Data::Dumper) module from CPAN and layer +it on top of either DB_File or GDBM_File. + +=head2 How can I make my hash remember the order I put elements into it? + +Use the Tie::IxHash from CPAN. + + use Tie::IxHash; + tie(%myhash, Tie::IxHash); + for ($i=0; $i<20; $i++) { + $myhash{$i} = 2*$i; + } + @keys = keys %myhash; + # @keys = (0,1,2,3,...) + +=head2 Why does passing a subroutine an undefined element in a hash create it? + +If you say something like: + + somefunc($hash{"nonesuch key here"}); + +Then that element "autovivifies"; that is, it springs into existence +whether you store something there or not. That's because functions +get scalars passed in by reference. If somefunc() modifies C<$_[0]>, +it has to be ready to write it back into the caller's version. + +This has been fixed as of perl5.004. + +Normally, merely accessing a key's value for a nonexistent key does +I<not> cause that key to be forever there. This is different than +awk's behavior. + +=head2 How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays? + +Use references (documented in L<perlref>). Examples of complex data +structures are given in L<perldsc> and L<perllol>. Examples of +structures and object-oriented classes are in L<perltoot>. + +=head2 How can I use a reference as a hash key? + +You can't do this directly, but you could use the standard Tie::Refhash +module distributed with perl. + +=head1 Data: Misc + +=head2 How do I handle binary data correctly? + +Perl is binary clean, so this shouldn't be a problem. For example, +this works fine (assuming the files are found): + + if (`cat /vmunix` =~ /gzip/) { + print "Your kernel is GNU-zip enabled!\n"; + } + +On some systems, however, you have to play tedious games with "text" +versus "binary" files. See L<perlfunc/"binmode">. + +If you're concerned about 8-bit ASCII data, then see L<perllocale>. + +If you want to deal with multibyte characters, however, there are +some gotchas. See the section on Regular Expressions. + +=head2 How do I determine whether a scalar is a number/whole/integer/float? + +Assuming that you don't care about IEEE notations like "NaN" or +"Infinity", you probably just want to use a regular expression. + + warn "has nondigits" if /\D/; + warn "not a whole number" unless /^\d+$/; + warn "not an integer" unless /^-?\d+$/; # reject +3 + warn "not an integer" unless /^[+-]?\d+$/; + warn "not a decimal number" unless /^-?\d+\.?\d*$/; # rejects .2 + warn "not a decimal number" unless /^-?(?:\d+(?:\.\d*)?|\.\d+)$/; + warn "not a C float" + unless /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; + +Or you could check out +http://www.perl.com/CPAN/modules/by-module/String/String-Scanf-1.1.tar.gz +instead. The POSIX module (part of the standard Perl distribution) +provides the C<strtol> and C<strtod> for converting strings to double +and longs, respectively. + +=head2 How do I keep persistent data across program calls? + +For some specific applications, you can use one of the DBM modules. +See L<AnyDBM_File>. More generically, you should consult the +FreezeThaw, Storable, or Class::Eroot modules from CPAN. + +=head2 How do I print out or copy a recursive data structure? + +The Data::Dumper module on CPAN is nice for printing out +data structures, and FreezeThaw for copying them. For example: + + use FreezeThaw qw(freeze thaw); + $new = thaw freeze $old; + +Where $old can be (a reference to) any kind of data structure you'd like. +It will be deeply copied. + +=head2 How do I define methods for every class/object? + +Use the UNIVERSAL class (see L<UNIVERSAL>). + +=head2 How do I verify a credit card checksum? + +Get the Business::CreditCard module from CPAN. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. + diff --git a/gnu/usr.bin/perl/pod/perlfaq5.pod b/gnu/usr.bin/perl/pod/perlfaq5.pod new file mode 100644 index 00000000000..03d5e6a797b --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq5.pod @@ -0,0 +1,830 @@ +=head1 NAME + +perlfaq5 - Files and Formats ($Revision: 1.22 $, $Date: 1997/04/24 22:44:02 $) + +=head1 DESCRIPTION + +This section deals with I/O and the "f" issues: filehandles, flushing, +formats, and footers. + +=head2 How do I flush/unbuffer a filehandle? Why must I do this? + +The C standard I/O library (stdio) normally buffers characters sent to +devices. This is done for efficiency reasons, so that there isn't a +system call for each byte. Any time you use print() or write() in +Perl, you go though this buffering. syswrite() circumvents stdio and +buffering. + +In most stdio implementations, the type of buffering and the size of +the buffer varies according to the type of device. Disk files are block +buffered, often with a buffer size of more than 2k. Pipes and sockets +are often buffered with a buffer size between 1/2 and 2k. Serial devices +(e.g. modems, terminals) are normally line-buffered, and stdio sends +the entire line when it gets the newline. + +Perl does not support truly unbuffered output (except insofar as you can +C<syswrite(OUT, $char, 1)>). What it does instead support is "command +buffering", in which a physical write is performed after every output +command. This isn't as hard on your system as unbuffering, but does +get the output where you want it when you want it. + +If you expect characters to get to your device when you print them there, +you'll want to autoflush its handle, as in the older: + + use FileHandle; + open(DEV, "<+/dev/tty"); # ceci n'est pas une pipe + DEV->autoflush(1); + +or the newer IO::* modules: + + use IO::Handle; + open(DEV, ">/dev/printer"); # but is this? + DEV->autoflush(1); + +or even this: + + use IO::Socket; # this one is kinda a pipe? + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.com', + PeerPort => 'http(80)', + Proto => 'tcp'); + die "$!" unless $sock; + + $sock->autoflush(); + $sock->print("GET /\015\012"); + $document = join('', $sock->getlines()); + print "DOC IS: $document\n"; + +Note the hardcoded carriage return and newline in their octal +equivalents. This is the ONLY way (currently) to assure a proper +flush on all platforms, including Macintosh. + +You can use select() and the C<$|> variable to control autoflushing +(see L<perlvar/$|> and L<perlfunc/select>): + + $oldh = select(DEV); + $| = 1; + select($oldh); + +You'll also see code that does this without a temporary variable, as in + + select((select(DEV), $| = 1)[0]); + +=head2 How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file? + +Although humans have an easy time thinking of a text file as being a +sequence of lines that operates much like a stack of playing cards -- +or punch cards -- computers usually see the text file as a sequence of +bytes. In general, there's no direct way for Perl to seek to a +particular line of a file, insert text into a file, or remove text +from a file. + +(There are exceptions in special circumstances. Replacing a sequence +of bytes with another sequence of the same length is one. Another is +using the C<$DB_RECNO> array bindings as documented in L<DB_File>. +Yet another is manipulating files with all lines the same length.) + +The general solution is to create a temporary copy of the text file with +the changes you want, then copy that over the original. + + $old = $file; + $new = "$file.tmp.$$"; + $bak = "$file.bak"; + + open(OLD, "< $old") or die "can't open $old: $!"; + open(NEW, "> $new") or die "can't open $new: $!"; + + # Correct typos, preserving case + while (<OLD>) { + s/\b(p)earl\b/${1}erl/i; + (print NEW $_) or die "can't write to $new: $!"; + } + + close(OLD) or die "can't close $old: $!"; + close(NEW) or die "can't close $new: $!"; + + rename($old, $bak) or die "can't rename $old to $bak: $!"; + rename($new, $old) or die "can't rename $new to $old: $!"; + +Perl can do this sort of thing for you automatically with the C<-i> +command-line switch or the closely-related C<$^I> variable (see +L<perlrun> for more details). Note that +C<-i> may require a suffix on some non-Unix systems; see the +platform-specific documentation that came with your port. + + # Renumber a series of tests from the command line + perl -pi -e 's/(^\s+test\s+)\d+/ $1 . ++$count /e' t/op/taint.t + + # form a script + local($^I, @ARGV) = ('.bak', glob("*.c")); + while (<>) { + if ($. == 1) { + print "This line should appear at the top of each file\n"; + } + s/\b(p)earl\b/${1}erl/i; # Correct typos, preserving case + print; + close ARGV if eof; # Reset $. + } + +If you need to seek to an arbitrary line of a file that changes +infrequently, you could build up an index of byte positions of where +the line ends are in the file. If the file is large, an index of +every tenth or hundredth line end would allow you to seek and read +fairly efficiently. If the file is sorted, try the look.pl library +(part of the standard perl distribution). + +In the unique case of deleting lines at the end of a file, you +can use tell() and truncate(). The following code snippet deletes +the last line of a file without making a copy or reading the +whole file into memory: + + open (FH, "+< $file"); + while ( <FH> ) { $addr = tell(FH) unless eof(FH) } + truncate(FH, $addr); + +Error checking is left as an exercise for the reader. + +=head2 How do I count the number of lines in a file? + +One fairly efficient way is to count newlines in the file. The +following program uses a feature of tr///, as documented in L<perlop>. +If your text file doesn't end with a newline, then it's not really a +proper text file, so this may report one fewer line than you expect. + + $lines = 0; + open(FILE, $filename) or die "Can't open `$filename': $!"; + while (sysread FILE, $buffer, 4096) { + $lines += ($buffer =~ tr/\n//); + } + close FILE; + +=head2 How do I make a temporary file name? + +Use the process ID and/or the current time-value. If you need to have +many temporary files in one process, use a counter: + + BEGIN { + use IO::File; + use Fcntl; + my $temp_dir = -d '/tmp' ? '/tmp' : $ENV{TMP} || $ENV{TEMP}; + my $base_name = sprintf("%s/%d-%d-0000", $temp_dir, $$, time()); + sub temp_file { + my $fh = undef; + my $count = 0; + until (defined($fh) || $count > 100) { + $base_name =~ s/-(\d+)$/"-" . (1 + $1)/e; + $fh = IO::File->new($base_name, O_WRONLY|O_EXCL|O_CREAT, 0644) + } + if (defined($fh)) { + return ($fh, $base_name); + } else { + return (); + } + } + } + +Or you could simply use IO::Handle::new_tmpfile. + +=head2 How can I manipulate fixed-record-length files? + +The most efficient way is using pack() and unpack(). This is faster +than using substr(). Here is a sample chunk of code to break up and +put back together again some fixed-format input lines, in this case +from the output of a normal, Berkeley-style ps: + + # sample input line: + # 15158 p5 T 0:00 perl /home/tchrist/scripts/now-what + $PS_T = 'A6 A4 A7 A5 A*'; + open(PS, "ps|"); + $_ = <PS>; print; + while (<PS>) { + ($pid, $tt, $stat, $time, $command) = unpack($PS_T, $_); + for $var (qw!pid tt stat time command!) { + print "$var: <$$var>\n"; + } + print 'line=', pack($PS_T, $pid, $tt, $stat, $time, $command), + "\n"; + } + +=head2 How can I make a filehandle local to a subroutine? How do I pass filehandles between subroutines? How do I make an array of filehandles? + +You may have some success with typeglobs, as we always had to use +in days of old: + + local(*FH); + +But while still supported, that isn't the best to go about getting +local filehandles. Typeglobs have their drawbacks. You may well want +to use the C<FileHandle> module, which creates new filehandles for you +(see L<FileHandle>): + + use FileHandle; + sub findme { + my $fh = FileHandle->new(); + open($fh, "</etc/hosts") or die "no /etc/hosts: $!"; + while (<$fh>) { + print if /\b127\.(0\.0\.)?1\b/; + } + # $fh automatically closes/disappears here + } + +Internally, Perl believes filehandles to be of class IO::Handle. You +may use that module directly if you'd like (see L<IO::Handle>), or +one of its more specific derived classes. + +Once you have IO::File or FileHandle objects, you can pass them +between subroutines or store them in hashes as you would any other +scalar values: + + use FileHandle; + + # Storing filehandles in a hash and array + foreach $filename (@names) { + my $fh = new FileHandle($filename) or die; + $file{$filename} = $fh; + push(@files, $fh); + } + + # Using the filehandles in the array + foreach $file (@files) { + print $file "Testing\n"; + } + + # You have to do the { } ugliness when you're specifying the + # filehandle by anything other than a simple scalar variable. + print { $files[2] } "Testing\n"; + + # Passing filehandles to subroutines + sub debug { + my $filehandle = shift; + printf $filehandle "DEBUG: ", @_; + } + + debug($fh, "Testing\n"); + +=head2 How can I set up a footer format to be used with write()? + +There's no builtin way to do this, but L<perlform> has a couple of +techniques to make it possible for the intrepid hacker. + +=head2 How can I write() into a string? + +See L<perlform> for an swrite() function. + +=head2 How can I output my numbers with commas added? + +This one will do it for you: + + sub commify { + local $_ = shift; + 1 while s/^(-?\d+)(\d{3})/$1,$2/; + return $_; + } + + $n = 23659019423.2331; + print "GOT: ", commify($n), "\n"; + + GOT: 23,659,019,423.2331 + +You can't just: + + s/^(-?\d+)(\d{3})/$1,$2/g; + +because you have to put the comma in and then recalculate your +position. + +Alternatively, this commifies all numbers in a line regardless of +whether they have decimal portions, are preceded by + or -, or +whatever: + + # from Andrew Johnson <ajohnson@gpu.srv.ualberta.ca> + sub commify { + my $input = shift; + $input = reverse $input; + $input =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g; + return reverse $input; + } + +=head2 How can I translate tildes (~) in a filename? + +Use the E<lt>E<gt> (glob()) operator, documented in L<perlfunc>. This +requires that you have a shell installed that groks tildes, meaning +csh or tcsh or (some versions of) ksh, and thus may have portability +problems. The Glob::KGlob module (available from CPAN) gives more +portable glob functionality. + +Within Perl, you may use this directly: + + $filename =~ s{ + ^ ~ # find a leading tilde + ( # save this in $1 + [^/] # a non-slash character + * # repeated 0 or more times (0 means me) + ) + }{ + $1 + ? (getpwnam($1))[7] + : ( $ENV{HOME} || $ENV{LOGDIR} ) + }ex; + +=head2 How come when I open the file read-write it wipes it out? + +Because you're using something like this, which truncates the file and +I<then> gives you read-write access: + + open(FH, "+> /path/name"); # WRONG + +Whoops. You should instead use this, which will fail if the file +doesn't exist. + + open(FH, "+< /path/name"); # open for update + +If this is an issue, try: + + sysopen(FH, "/path/name", O_RDWR|O_CREAT, 0644); + +Error checking is left as an exercise for the reader. + +=head2 Why do I sometimes get an "Argument list too long" when I use <*>? + +The C<E<lt>E<gt>> operator performs a globbing operation (see above). +By default glob() forks csh(1) to do the actual glob expansion, but +csh can't handle more than 127 items and so gives the error message +C<Argument list too long>. People who installed tcsh as csh won't +have this problem, but their users may be surprised by it. + +To get around this, either do the glob yourself with C<Dirhandle>s and +patterns, or use a module like Glob::KGlob, one that doesn't use the +shell to do globbing. + +=head2 Is there a leak/bug in glob()? + +Due to the current implementation on some operating systems, when you +use the glob() function or its angle-bracket alias in a scalar +context, you may cause a leak and/or unpredictable behavior. It's +best therefore to use glob() only in list context. + +=head2 How can I open a file with a leading "E<gt>" or trailing blanks? + +Normally perl ignores trailing blanks in filenames, and interprets +certain leading characters (or a trailing "|") to mean something +special. To avoid this, you might want to use a routine like this. +It makes incomplete pathnames into explicit relative ones, and tacks a +trailing null byte on the name to make perl leave it alone: + + sub safe_filename { + local $_ = shift; + return m#^/# + ? "$_\0" + : "./$_\0"; + } + + $fn = safe_filename("<<<something really wicked "); + open(FH, "> $fn") or "couldn't open $fn: $!"; + +You could also use the sysopen() function (see L<perlfunc/sysopen>). + +=head2 How can I reliably rename a file? + +Well, usually you just use Perl's rename() function. But that may +not work everywhere, in particular, renaming files across file systems. +If your operating system supports a mv(1) program or its moral 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 semantics as a +real rename(), though, which preserves metainformation like +permissions, timestamps, inode info, etc. + +=head2 How can I lock a file? + +Perl's builtin flock() function (see L<perlfunc> for details) will call +flock(2) if that exists, fcntl(2) if it doesn't (on perl version 5.004 and +later), and lockf(3) if neither of the two previous system calls exists. +On some systems, it may even use a different form of native locking. +Here are some gotchas with Perl's flock(): + +=over 4 + +=item 1 + +Produces a fatal error if none of the three system calls (or their +close equivalent) exists. + +=item 2 + +lockf(3) does not provide shared locking, and requires that the +filehandle be open for writing (or appending, or read/writing). + +=item 3 + +Some versions of flock() can't lock files over a network (e.g. on NFS +file systems), so you'd need to force the use of fcntl(2) when you +build Perl. See the flock entry of L<perlfunc>, and the F<INSTALL> +file in the source distribution for information on building Perl to do +this. + +=back + +The CPAN module File::Lock offers similar functionality and (if you +have dynamic loading) won't require you to rebuild perl if your +flock() can't lock network files. + +=head2 What can't I just open(FH, ">file.lock")? + +A common bit of code B<NOT TO USE> is this: + + sleep(3) while -e "file.lock"; # PLEASE DO NOT USE + open(LCK, "> file.lock"); # THIS BROKEN CODE + +This is a classic race condition: you take two steps to do something +which must be done in one. That's why computer hardware provides an +atomic test-and-set instruction. In theory, this "ought" to work: + + sysopen(FH, "file.lock", O_WRONLY|O_EXCL|O_CREAT, 0644) + or die "can't open file.lock: $!": + +except that lamentably, file creation (and deletion) is not atomic +over NFS, so this won't work (at least, not every time) over the net. +Various schemes involving involving link() have been suggested, but +these tend to involve busy-wait, which is also subdesirable. + +=head2 I still don't get locking. I just want to increment the number in the file. How can I do this? + +Didn't anyone ever tell you web-page hit counters were useless? + +Anyway, this is what to do: + + use Fcntl; + sysopen(FH, "numfile", O_RDWR|O_CREAT, 0644) or die "can't open numfile: $!"; + flock(FH, 2) or die "can't flock numfile: $!"; + $num = <FH> || 0; + seek(FH, 0, 0) or die "can't rewind numfile: $!"; + truncate(FH, 0) or die "can't truncate numfile: $!"; + (print FH $num+1, "\n") or die "can't write numfile: $!"; + # DO NOT UNLOCK THIS UNTIL YOU CLOSE + close FH or die "can't close numfile: $!"; + +Here's a much better web-page hit counter: + + $hits = int( (time() - 850_000_000) / rand(1_000) ); + +If the count doesn't impress your friends, then the code might. :-) + +=head2 How do I randomly update a binary file? + +If you're just trying to patch a binary, in many cases something as +simple as this works: + + perl -i -pe 's{window manager}{window mangler}g' /usr/bin/emacs + +However, if you have fixed sized records, then you might do something more +like this: + + $RECSIZE = 220; # size of record, in bytes + $recno = 37; # which record to update + open(FH, "+<somewhere") || die "can't update somewhere: $!"; + seek(FH, $recno * $RECSIZE, 0); + read(FH, $record, $RECSIZE) == $RECSIZE || die "can't read record $recno: $!"; + # munge the record + seek(FH, $recno * $RECSIZE, 0); + print FH $record; + close FH; + +Locking and error checking are left as an exercise for the reader. +Don't forget them, or you'll be quite sorry. + +Don't forget to set binmode() under DOS-like platforms when operating +on files that have anything other than straight text in them. See the +docs on open() and on binmode() for more details. + +=head2 How do I get a file's timestamp in perl? + +If you want to retrieve the time at which the file was last read, +written, or had its meta-data (owner, etc) changed, you use the B<-M>, +B<-A>, or B<-C> filetest operations as documented in L<perlfunc>. These +retrieve the age of the file (measured against the start-time of your +program) in days as a floating point number. To retrieve the "raw" +time in seconds since the epoch, you would call the stat function, +then use localtime(), gmtime(), or POSIX::strftime() to convert this +into human-readable form. + +Here's an example: + + $write_secs = (stat($file))[9]; + print "file $file updated at ", scalar(localtime($file)), "\n"; + +If you prefer something more legible, use the File::stat module +(part of the standard distribution in version 5.004 and later): + + use File::stat; + use Time::localtime; + $date_string = ctime(stat($file)->mtime); + print "file $file updated at $date_string\n"; + +Error checking is left as an exercise for the reader. + +=head2 How do I set a file's timestamp in perl? + +You use the utime() function documented in L<perlfunc/utime>. +By way of example, here's a little program that copies the +read and write times from its first argument to all the rest +of them. + + if (@ARGV < 2) { + die "usage: cptimes timestamp_file other_files ...\n"; + } + $timestamp = shift; + ($atime, $mtime) = (stat($timestamp))[8,9]; + utime $atime, $mtime, @ARGV; + +Error checking is left as an exercise for the reader. + +Note that utime() currently doesn't work correctly with Win95/NT +ports. A bug has been reported. Check it carefully before using +it on those platforms. + +=head2 How do I print to more than one file at once? + +If you only have to do this once, you can do this: + + for $fh (FH1, FH2, FH3) { print $fh "whatever\n" } + +To connect up to one filehandle to several output filehandles, it's +easiest to use the tee(1) program if you have it, and let it take care +of the multiplexing: + + open (FH, "| tee file1 file2 file3"); + +Otherwise you'll have to write your own multiplexing print function -- +or your own tee program -- or use Tom Christiansen's, at +http://www.perl.com/CPAN/authors/id/TOMC/scripts/tct.gz, which is +written in Perl. + +In theory a IO::Tee class could be written, but to date we haven't +seen such. + +=head2 How can I read in a file by paragraphs? + +Use the C<$\> variable (see L<perlvar> for details). You can either +set it to C<""> to eliminate empty paragraphs (C<"abc\n\n\n\ndef">, +for instance, gets treated as two paragraphs and not three), or +C<"\n\n"> to accept empty paragraphs. + +=head2 How can I read a single character from a file? From the keyboard? + +You can use the builtin C<getc()> function for most filehandles, but +it won't (easily) work on a terminal device. For STDIN, either use +the Term::ReadKey module from CPAN, or use the sample code in +L<perlfunc/getc>. + +If your system supports POSIX, you can use the following code, which +you'll note turns off echo processing as well. + + #!/usr/bin/perl -w + use strict; + $| = 1; + for (1..4) { + my $got; + print "gimme: "; + $got = getone(); + print "--> $got\n"; + } + exit; + + BEGIN { + use POSIX qw(:termios_h); + + my ($term, $oterm, $echo, $noecho, $fd_stdin); + + $fd_stdin = fileno(STDIN); + + $term = POSIX::Termios->new(); + $term->getattr($fd_stdin); + $oterm = $term->getlflag(); + + $echo = ECHO | ECHOK | ICANON; + $noecho = $oterm & ~$echo; + + sub cbreak { + $term->setlflag($noecho); + $term->setcc(VTIME, 1); + $term->setattr($fd_stdin, TCSANOW); + } + + sub cooked { + $term->setlflag($oterm); + $term->setcc(VTIME, 0); + $term->setattr($fd_stdin, TCSANOW); + } + + sub getone { + my $key = ''; + cbreak(); + sysread(STDIN, $key, 1); + cooked(); + return $key; + } + + } + + END { cooked() } + +The Term::ReadKey module from CPAN may be easier to use: + + use Term::ReadKey; + open(TTY, "</dev/tty"); + print "Gimme a char: "; + ReadMode "raw"; + $key = ReadKey 0, *TTY; + ReadMode "normal"; + printf "\nYou said %s, char number %03d\n", + $key, ord $key; + +For DOS systems, Dan Carson <dbc@tc.fluke.COM> reports the following: + +To put the PC in "raw" mode, use ioctl with some magic numbers gleaned +from msdos.c (Perl source file) and Ralf Brown's interrupt list (comes +across the net every so often): + + $old_ioctl = ioctl(STDIN,0,0); # Gets device info + $old_ioctl &= 0xff; + ioctl(STDIN,1,$old_ioctl | 32); # Writes it back, setting bit 5 + +Then to read a single character: + + sysread(STDIN,$c,1); # Read a single character + +And to put the PC back to "cooked" mode: + + ioctl(STDIN,1,$old_ioctl); # Sets it back to cooked mode. + +So now you have $c. If C<ord($c) == 0>, you have a two byte code, which +means you hit a special key. Read another byte with C<sysread(STDIN,$c,1)>, +and that value tells you what combination it was according to this +table: + + # PC 2-byte keycodes = ^@ + the following: + + # HEX KEYS + # --- ---- + # 0F SHF TAB + # 10-19 ALT QWERTYUIOP + # 1E-26 ALT ASDFGHJKL + # 2C-32 ALT ZXCVBNM + # 3B-44 F1-F10 + # 47-49 HOME,UP,PgUp + # 4B LEFT + # 4D RIGHT + # 4F-53 END,DOWN,PgDn,Ins,Del + # 54-5D SHF F1-F10 + # 5E-67 CTR F1-F10 + # 68-71 ALT F1-F10 + # 73-77 CTR LEFT,RIGHT,END,PgDn,HOME + # 78-83 ALT 1234567890-= + # 84 CTR PgUp + +This is all trial and error I did a long time ago, I hope I'm reading the +file that worked. + +=head2 How can I tell if there's a character waiting on a filehandle? + +You should check out the Frequently Asked Questions list in +comp.unix.* for things like this: the answer is essentially the same. +It's very system dependent. Here's one solution that works on BSD +systems: + + sub key_ready { + my($rin, $nfd); + vec($rin, fileno(STDIN), 1) = 1; + return $nfd = select($rin,undef,undef,0); + } + +You should look into getting the Term::ReadKey extension from CPAN. + +=head2 How do I open a file without blocking? + +You need to use the O_NDELAY or O_NONBLOCK flag from the Fcntl module +in conjunction with sysopen(): + + use Fcntl; + sysopen(FH, "/tmp/somefile", O_WRONLY|O_NDELAY|O_CREAT, 0644) + or die "can't open /tmp/somefile: $!": + +=head2 How do I create a file only if it doesn't exist? + +You need to use the O_CREAT and O_EXCL flags from the Fcntl module in +conjunction with sysopen(): + + use Fcntl; + sysopen(FH, "/tmp/somefile", O_WRONLY|O_EXCL|O_CREAT, 0644) + or die "can't open /tmp/somefile: $!": + +Be warned that neither creation nor deletion of files is guaranteed to +be an atomic operation over NFS. That is, two processes might both +successful create or unlink the same file! + +=head2 How do I do a C<tail -f> in perl? + +First try + + seek(GWFILE, 0, 1); + +The statement C<seek(GWFILE, 0, 1)> doesn't change the current position, +but it does clear the end-of-file condition on the handle, so that the +next <GWFILE> makes Perl try again to read something. + +If that doesn't work (it relies on features of your stdio implementation), +then you need something more like this: + + for (;;) { + for ($curpos = tell(GWFILE); <GWFILE>; $curpos = tell(GWFILE)) { + # search for some stuff and put it into files + } + # sleep for a while + seek(GWFILE, $curpos, 0); # seek to where we had been + } + +If this still doesn't work, look into the POSIX module. POSIX defines +the clearerr() method, which can remove the end of file condition on a +filehandle. The method: read until end of file, clearerr(), read some +more. Lather, rinse, repeat. + +=head2 How do I dup() a filehandle in Perl? + +If you check L<perlfunc/open>, you'll see that several of the ways +to call open() should do the trick. For example: + + open(LOG, ">>/tmp/logfile"); + open(STDERR, ">&LOG"); + +Or even with a literal numeric descriptor: + + $fd = $ENV{MHCONTEXTFD}; + open(MHCONTEXT, "<&=$fd"); # like fdopen(3S) + +Error checking has been left as an exercise for the reader. + +=head2 How do I close a file descriptor by number? + +This should rarely be necessary, as the Perl close() function is to be +used for things that Perl opened itself, even if it was a dup of a +numeric descriptor, as with MHCONTEXT above. But if you really have +to, you may be able to do this: + + require 'sys/syscall.ph'; + $rc = syscall(&SYS_close, $fd + 0); # must force numeric + die "can't sysclose $fd: $!" unless $rc == -1; + +=head2 Why can't I use "C:\temp\foo" in DOS paths? What doesn't `C:\temp\foo.exe` work? + +Whoops! You just put a tab and a formfeed into that filename! +Remember that within double quoted strings ("like\this"), the +backslash is an escape character. The full list of these is in +L<perlop/Quote and Quote-like Operators>. Unsurprisingly, you don't +have a file called "c:(tab)emp(formfeed)oo" or +"c:(tab)emp(formfeed)oo.exe" on your DOS filesystem. + +Either single-quote your strings, or (preferably) use forward slashes. +Since all DOS and Windows versions since something like MS-DOS 2.0 or so +have treated C</> and C<\> the same in a path, you might as well use the +one that doesn't clash with Perl -- or the POSIX shell, ANSI C and C++, +awk, Tcl, Java, or Python, just to mention a few. + +=head2 Why doesn't glob("*.*") get all the files? + +Because even on non-Unix ports, Perl's glob function follows standard +Unix globbing semantics. You'll need C<glob("*")> to get all (non-hidden) +files. + +=head2 Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl? + +This is elaborately and painstakingly described in the "Far More Than +You Every Wanted To Know" in +http://www.perl.com/CPAN/doc/FMTEYEWTK/file-dir-perms . + +The executive summary: learn how your filesystem works. The +permissions on a file say what can happen to the data in that file. +The permissions on a directory say what can happen to the list of +files in that directory. If you delete a file, you're removing its +name from the directory (so the operation depends on the permissions +of the directory, not of the file). If you try to write to the file, +the permissions of the file govern whether you're allowed to. + +=head2 How do I select a random line from a file? + +Here's an algorithm from the Camel Book: + + srand; + rand($.) < 1 && ($line = $_) while <>; + +This has a significant advantage in space over reading the whole +file in. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. + diff --git a/gnu/usr.bin/perl/pod/perlfaq6.pod b/gnu/usr.bin/perl/pod/perlfaq6.pod new file mode 100644 index 00000000000..535e4644551 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq6.pod @@ -0,0 +1,605 @@ +=head1 NAME + +perlfaq6 - Regexps ($Revision: 1.17 $, $Date: 1997/04/24 22:44:10 $) + +=head1 DESCRIPTION + +This section is surprisingly small because the rest of the FAQ is +littered with answers involving regular expressions. For example, +decoding a URL and checking whether something is a number are handled +with regular expressions, but those answers are found elsewhere in +this document (in the section on Data and the Networking one on +networking, to be precise). + +=head2 How can I hope to use regular expressions without creating illegible and unmaintainable code? + +Three techniques can make regular expressions maintainable and +understandable. + +=over 4 + +=item Comments Outside the Regexp + +Describe what you're doing and how you're doing it, using normal Perl +comments. + + # turn the line into the first word, a colon, and the + # number of characters on the rest of the line + s/^(\w+)(.*)/ lc($1) . ":" . length($2) /ge; + +=item Comments Inside the Regexp + +The C</x> modifier causes whitespace to be ignored in a regexp pattern +(except in a character class), and also allows you to use normal +comments there, too. As you can imagine, whitespace and comments help +a lot. + +C</x> lets you turn this: + + s{<(?:[^>'"]*|".*?"|'.*?')+>}{}gs; + +into this: + + s{ < # opening angle bracket + (?: # Non-backreffing grouping paren + [^>'"] * # 0 or more things that are neither > nor ' nor " + | # or else + ".*?" # a section between double quotes (stingy match) + | # or else + '.*?' # a section between single quotes (stingy match) + ) + # all occurring one or more times + > # closing angle bracket + }{}gsx; # replace with nothing, i.e. delete + +It's still not quite so clear as prose, but it is very useful for +describing the meaning of each part of the pattern. + +=item Different Delimiters + +While we normally think of patterns as being delimited with C</> +characters, they can be delimited by almost any character. L<perlre> +describes this. For example, the C<s///> above uses braces as +delimiters. Selecting another delimiter can avoid quoting the +delimiter within the pattern: + + s/\/usr\/local/\/usr\/share/g; # bad delimiter choice + s#/usr/local#/usr/share#g; # better + +=back + +=head2 I'm having trouble matching over more than one line. What's wrong? + +Either you don't have newlines in your string, or you aren't using the +correct modifier(s) on your pattern. + +There are many ways to get multiline data into a string. If you want +it to happen automatically while reading input, you'll want to set $/ +(probably to '' for paragraphs or C<undef> for the whole file) to +allow you to read more than one line at a time. + +Read L<perlre> to help you decide which of C</s> and C</m> (or both) +you might want to use: C</s> allows dot to include newline, and C</m> +allows caret and dollar to match next to a newline, not just at the +end of the string. You do need to make sure that you've actually +got a multiline string in there. + +For example, this program detects duplicate words, even when they span +line breaks (but not paragraph ones). For this example, we don't need +C</s> because we aren't using dot in a regular expression that we want +to cross line boundaries. Neither do we need C</m> because we aren't +wanting caret or dollar to match at any point inside the record next +to newlines. But it's imperative that $/ be set to something other +than the default, or else we won't actually ever have a multiline +record read in. + + $/ = ''; # read in more whole paragraph, not just one line + while ( <> ) { + while ( /\b(\w\S+)(\s+\1)+\b/gi ) { + print "Duplicate $1 at paragraph $.\n"; + } + } + +Here's code that finds sentences that begin with "From " (which would +be mangled by many mailers): + + $/ = ''; # read in more whole paragraph, not just one line + while ( <> ) { + while ( /^From /gm ) { # /m makes ^ match next to \n + print "leading from in paragraph $.\n"; + } + } + +Here's code that finds everything between START and END in a paragraph: + + undef $/; # read in whole file, not just one line or paragraph + while ( <> ) { + while ( /START(.*?)END/sm ) { # /s makes . cross line boundaries + print "$1\n"; + } + } + +=head2 How can I pull out lines between two patterns that are themselves on different lines? + +You can use Perl's somewhat exotic C<..> operator (documented in +L<perlop>): + + perl -ne 'print if /START/ .. /END/' file1 file2 ... + +If you wanted text and not lines, you would use + + perl -0777 -pe 'print "$1\n" while /START(.*?)END/gs' file1 file2 ... + +But if you want nested occurrences of C<START> through C<END>, you'll +run up against the problem described in the question in this section +on matching balanced text. + +=head2 I put a regular expression into $/ but it didn't work. What's wrong? + +$/ must be a string, not a regular expression. Awk has to be better +for something. :-) + +Actually, you could do this if you don't mind reading the whole file +into memory: + + undef $/; + @records = split /your_pattern/, <FH>; + +The Net::Telnet module (available from CPAN) has the capability to +wait for a pattern in the input stream, or timeout if it doesn't +appear within a certain time. + + ## Create a file with three lines. + open FH, ">file"; + print FH "The first line\nThe second line\nThe third line\n"; + close FH; + + ## Get a read/write filehandle to it. + $fh = new FileHandle "+<file"; + + ## Attach it to a "stream" object. + use Net::Telnet; + $file = new Net::Telnet (-fhopen => $fh); + + ## Search for the second line and print out the third. + $file->waitfor('/second line\n/'); + print $file->getline; + +=head2 How do I substitute case insensitively on the LHS, but preserving case on the RHS? + +It depends on what you mean by "preserving case". The following +script makes the substitution have the same case, letter by letter, as +the original. If the substitution has more characters than the string +being substituted, the case of the last character is used for the rest +of the substitution. + + # Original by Nathan Torkington, massaged by Jeffrey Friedl + # + sub preserve_case($$) + { + my ($old, $new) = @_; + my ($state) = 0; # 0 = no change; 1 = lc; 2 = uc + my ($i, $oldlen, $newlen, $c) = (0, length($old), length($new)); + my ($len) = $oldlen < $newlen ? $oldlen : $newlen; + + for ($i = 0; $i < $len; $i++) { + if ($c = substr($old, $i, 1), $c =~ /[\W\d_]/) { + $state = 0; + } elsif (lc $c eq $c) { + substr($new, $i, 1) = lc(substr($new, $i, 1)); + $state = 1; + } else { + substr($new, $i, 1) = uc(substr($new, $i, 1)); + $state = 2; + } + } + # finish up with any remaining new (for when new is longer than old) + if ($newlen > $oldlen) { + if ($state == 1) { + substr($new, $oldlen) = lc(substr($new, $oldlen)); + } elsif ($state == 2) { + substr($new, $oldlen) = uc(substr($new, $oldlen)); + } + } + return $new; + } + + $a = "this is a TEsT case"; + $a =~ s/(test)/preserve_case($1, "success")/gie; + print "$a\n"; + +This prints: + + this is a SUcCESS case + +=head2 How can I make C<\w> match accented characters? + +See L<perllocale>. + +=head2 How can I match a locale-smart version of C</[a-zA-Z]/>? + +One alphabetic character would be C</[^\W\d_]/>, no matter what locale +you're in. Non-alphabetics would be C</[\W\d_]/> (assuming you don't +consider an underscore a letter). + +=head2 How can I quote a variable to use in a regexp? + +The Perl parser will expand $variable and @variable references in +regular expressions unless the delimiter is a single quote. Remember, +too, that the right-hand side of a C<s///> substitution is considered +a double-quoted string (see L<perlop> for more details). Remember +also that any regexp special characters will be acted on unless you +precede the substitution with \Q. Here's an example: + + $string = "to die?"; + $lhs = "die?"; + $rhs = "sleep no more"; + + $string =~ s/\Q$lhs/$rhs/; + # $string is now "to sleep no more" + +Without the \Q, the regexp would also spuriously match "di". + +=head2 What is C</o> really for? + +Using a variable in a regular expression match forces a re-evaluation +(and perhaps recompilation) each time through. The C</o> modifier +locks in the regexp the first time it's used. This always happens in a +constant regular expression, and in fact, the pattern was compiled +into the internal format at the same time your entire program was. + +Use of C</o> is irrelevant unless variable interpolation is used in +the pattern, and if so, the regexp engine will neither know nor care +whether the variables change after the pattern is evaluated the I<very +first> time. + +C</o> is often used to gain an extra measure of efficiency by not +performing subsequent evaluations when you know it won't matter +(because you know the variables won't change), or more rarely, when +you don't want the regexp to notice if they do. + +For example, here's a "paragrep" program: + + $/ = ''; # paragraph mode + $pat = shift; + while (<>) { + print if /$pat/o; + } + +=head2 How do I use a regular expression to strip C style comments from a file? + +While this actually can be done, it's much harder than you'd think. +For example, this one-liner + + perl -0777 -pe 's{/\*.*?\*/}{}gs' foo.c + +will work in many but not all cases. You see, it's too simple-minded for +certain kinds of C programs, in particular, those with what appear to be +comments in quoted strings. For that, you'd need something like this, +created by Jeffrey Friedl: + + $/ = undef; + $_ = <>; + s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|\n+|.[^/"'\\]*)#$2#g; + print; + +This could, of course, be more legibly written with the C</x> modifier, adding +whitespace and comments. + +=head2 Can I use Perl regular expressions to match balanced text? + +Although Perl regular expressions are more powerful than "mathematical" +regular expressions, because they feature conveniences like backreferences +(C<\1> and its ilk), they still aren't powerful enough. You still need +to use non-regexp techniques to parse balanced text, such as the text +enclosed between matching parentheses or braces, for example. + +An elaborate subroutine (for 7-bit ASCII only) to pull out balanced +and possibly nested single chars, like C<`> and C<'>, C<{> and C<}>, +or C<(> and C<)> can be found in +http://www.perl.com/CPAN/authors/id/TOMC/scripts/pull_quotes.gz . + +The C::Scan module from CPAN contains such subs for internal usage, +but they are undocumented. + +=head2 What does it mean that regexps are greedy? How can I get around it? + +Most people mean that greedy regexps match as much as they can. +Technically speaking, it's actually the quantifiers (C<?>, C<*>, C<+>, +C<{}>) that are greedy rather than the whole pattern; Perl prefers local +greed and immediate gratification to overall greed. To get non-greedy +versions of the same quantifiers, use (C<??>, C<*?>, C<+?>, C<{}?>). + +An example: + + $s1 = $s2 = "I am very very cold"; + $s1 =~ s/ve.*y //; # I am cold + $s2 =~ s/ve.*?y //; # I am very cold + +Notice how the second substitution stopped matching as soon as it +encountered "y ". The C<*?> quantifier effectively tells the regular +expression engine to find a match as quickly as possible and pass +control on to whatever is next in line, like you would if you were +playing hot potato. + +=head2 How do I process each word on each line? + +Use the split function: + + while (<>) { + foreach $word ( split ) { + # do something with $word here + } + } + +Note that this isn't really a word in the English sense; it's just +chunks of consecutive non-whitespace characters. + +To work with only alphanumeric sequences, you might consider + + while (<>) { + foreach $word (m/(\w+)/g) { + # do something with $word here + } + } + +=head2 How can I print out a word-frequency or line-frequency summary? + +To do this, you have to parse out each word in the input stream. We'll +pretend that by word you mean chunk of alphabetics, hyphens, or +apostrophes, rather than the non-whitespace chunk idea of a word given +in the previous question: + + while (<>) { + while ( /(\b[^\W_\d][\w'-]+\b)/g ) { # misses "`sheep'" + $seen{$1}++; + } + } + while ( ($word, $count) = each %seen ) { + print "$count $word\n"; + } + +If you wanted to do the same thing for lines, you wouldn't need a +regular expression: + + while (<>) { + $seen{$_}++; + } + while ( ($line, $count) = each %seen ) { + print "$count $line"; + } + +If you want these output in a sorted order, see the section on Hashes. + +=head2 How can I do approximate matching? + +See the module String::Approx available from CPAN. + +=head2 How do I efficiently match many regular expressions at once? + +The following is super-inefficient: + + while (<FH>) { + foreach $pat (@patterns) { + if ( /$pat/ ) { + # do something + } + } + } + +Instead, you either need to use one of the experimental Regexp extension +modules from CPAN (which might well be overkill for your purposes), +or else put together something like this, inspired from a routine +in Jeffrey Friedl's book: + + sub _bm_build { + my $condition = shift; + my @regexp = @_; # this MUST not be local(); need my() + my $expr = join $condition => map { "m/\$regexp[$_]/o" } (0..$#regexp); + my $match_func = eval "sub { $expr }"; + die if $@; # propagate $@; this shouldn't happen! + return $match_func; + } + + sub bm_and { _bm_build('&&', @_) } + sub bm_or { _bm_build('||', @_) } + + $f1 = bm_and qw{ + xterm + (?i)window + }; + + $f2 = bm_or qw{ + \b[Ff]ree\b + \bBSD\B + (?i)sys(tem)?\s*[V5]\b + }; + + # feed me /etc/termcap, prolly + while ( <> ) { + print "1: $_" if &$f1; + print "2: $_" if &$f2; + } + +=head2 Why don't word-boundary searches with C<\b> work for me? + +Two common misconceptions are that C<\b> is a synonym for C<\s+>, and +that it's the edge between whitespace characters and non-whitespace +characters. Neither is correct. C<\b> is the place between a C<\w> +character and a C<\W> character (that is, C<\b> is the edge of a +"word"). It's a zero-width assertion, just like C<^>, C<$>, and all +the other anchors, so it doesn't consume any characters. L<perlre> +describes the behaviour of all the regexp metacharacters. + +Here are examples of the incorrect application of C<\b>, with fixes: + + "two words" =~ /(\w+)\b(\w+)/; # WRONG + "two words" =~ /(\w+)\s+(\w+)/; # right + + " =matchless= text" =~ /\b=(\w+)=\b/; # WRONG + " =matchless= text" =~ /=(\w+)=/; # right + +Although they may not do what you thought they did, C<\b> and C<\B> +can still be quite useful. For an example of the correct use of +C<\b>, see the example of matching duplicate words over multiple +lines. + +An example of using C<\B> is the pattern C<\Bis\B>. This will find +occurrences of "is" on the insides of words only, as in "thistle", but +not "this" or "island". + +=head2 Why does using $&, $`, or $' slow my program down? + +Because once Perl sees that you need one of these variables anywhere +in the program, it has to provide them on each and every pattern +match. The same mechanism that handles these provides for the use of +$1, $2, etc., so you pay the same price for each regexp that contains +capturing parentheses. But if you never use $&, etc., in your script, +then regexps I<without> capturing parentheses won't be penalized. So +avoid $&, $', and $` if you can, but if you can't (and some algorithms +really appreciate them), once you've used them once, use them at will, +because you've already paid the price. + +=head2 What good is C<\G> in a regular expression? + +The notation C<\G> is used in a match or substitution in conjunction the +C</g> modifier (and ignored if there's no C</g>) to anchor the regular +expression to the point just past where the last match occurred, i.e. the +pos() point. + +For example, suppose you had a line of text quoted in standard mail +and Usenet notation, (that is, with leading C<E<gt>> characters), and +you want change each leading C<E<gt>> into a corresponding C<:>. You +could do so in this way: + + s/^(>+)/':' x length($1)/gem; + +Or, using C<\G>, the much simpler (and faster): + + s/\G>/:/g; + +A more sophisticated use might involve a tokenizer. The following +lex-like example is courtesy of Jeffrey Friedl. It did not work in +5.003 due to bugs in that release, but does work in 5.004 or better. +(Note the use of C</c>, which prevents a failed match with C</g> from +resetting the search position back to the beginning of the string.) + + while (<>) { + chomp; + PARSER: { + m/ \G( \d+\b )/gcx && do { print "number: $1\n"; redo; }; + m/ \G( \w+ )/gcx && do { print "word: $1\n"; redo; }; + m/ \G( \s+ )/gcx && do { print "space: $1\n"; redo; }; + m/ \G( [^\w\d]+ )/gcx && do { print "other: $1\n"; redo; }; + } + } + +Of course, that could have been written as + + while (<>) { + chomp; + PARSER: { + if ( /\G( \d+\b )/gcx { + print "number: $1\n"; + redo PARSER; + } + if ( /\G( \w+ )/gcx { + print "word: $1\n"; + redo PARSER; + } + if ( /\G( \s+ )/gcx { + print "space: $1\n"; + redo PARSER; + } + if ( /\G( [^\w\d]+ )/gcx { + print "other: $1\n"; + redo PARSER; + } + } + } + +But then you lose the vertical alignment of the regular expressions. + +=head2 Are Perl regexps DFAs or NFAs? Are they POSIX compliant? + +While it's true that Perl's regular expressions resemble the DFAs +(deterministic finite automata) of the egrep(1) program, they are in +fact implemented as NFAs (non-deterministic finite automata) to allow +backtracking and backreferencing. And they aren't POSIX-style either, +because those guarantee worst-case behavior for all cases. (It seems +that some people prefer guarantees of consistency, even when what's +guaranteed is slowness.) See the book "Mastering Regular Expressions" +(from O'Reilly) by Jeffrey Friedl for all the details you could ever +hope to know on these matters (a full citation appears in +L<perlfaq2>). + +=head2 What's wrong with using grep or map in a void context? + +Strictly speaking, nothing. Stylistically speaking, it's not a good +way to write maintainable code. That's because you're using these +constructs not for their return values but rather for their +side-effects, and side-effects can be mystifying. There's no void +grep() that's not better written as a C<for> (well, C<foreach>, +technically) loop. + +=head2 How can I match strings with multibyte characters? + +This is hard, and there's no good way. Perl does not directly support +wide characters. It pretends that a byte and a character are +synonymous. The following set of approaches was offered by Jeffrey +Friedl, whose article in issue #5 of The Perl Journal talks about this +very matter. + +Let's suppose you have some weird Martian encoding where pairs of +ASCII uppercase letters encode single Martian letters (i.e. the two +bytes "CV" make a single Martian letter, as do the two bytes "SG", +"VS", "XX", etc.). Other bytes represent single characters, just like +ASCII. + +So, the string of Martian "I am CVSGXX!" uses 12 bytes to encode the +nine characters 'I', ' ', 'a', 'm', ' ', 'CV', 'SG', 'XX', '!'. + +Now, say you want to search for the single character C</GX/>. Perl +doesn't know about Martian, so it'll find the two bytes "GX" in the "I +am CVSGXX!" string, even though that character isn't there: it just +looks like it is because "SG" is next to "XX", but there's no real +"GX". This is a big problem. + +Here are a few ways, all painful, to deal with it: + + $martian =~ s/([A-Z][A-Z])/ $1 /g; # Make sure adjacent ``martian'' bytes + # are no longer adjacent. + print "found GX!\n" if $martian =~ /GX/; + +Or like this: + + @chars = $martian =~ m/([A-Z][A-Z]|[^A-Z])/g; + # above is conceptually similar to: @chars = $text =~ m/(.)/g; + # + foreach $char (@chars) { + print "found GX!\n", last if $char eq 'GX'; + } + +Or like this: + + while ($martian =~ m/\G([A-Z][A-Z]|.)/gs) { # \G probably unneeded + print "found GX!\n", last if $1 eq 'GX'; + } + +Or like this: + + die "sorry, Perl doesn't (yet) have Martian support )-:\n"; + +In addition, a sample program which converts half-width to full-width +katakana (in Shift-JIS or EUC encoding) is available from CPAN as + +=for Tom make it so + +There are many double- (and multi-) byte encodings commonly used these +days. Some versions of these have 1-, 2-, 3-, and 4-byte characters, +all mixed. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. + diff --git a/gnu/usr.bin/perl/pod/perlfaq7.pod b/gnu/usr.bin/perl/pod/perlfaq7.pod new file mode 100644 index 00000000000..283aa2bb34b --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq7.pod @@ -0,0 +1,717 @@ +=head1 NAME + +perlfaq7 - Perl Language Issues ($Revision: 1.18 $, $Date: 1997/04/24 22:44:14 $) + +=head1 DESCRIPTION + +This section deals with general Perl language issues that don't +clearly fit into any of the other sections. + +=head2 Can I get a BNF/yacc/RE for the Perl language? + +No, in the words of Chaim Frenkel: "Perl's grammar can not be reduced +to BNF. The work of parsing perl is distributed between yacc, the +lexer, smoke and mirrors." + +=head2 What are all these $@%* punctuation signs, and how do I know when to use them? + +They are type specifiers, as detailed in L<perldata>: + + $ for scalar values (number, string or reference) + @ for arrays + % for hashes (associative arrays) + * for all types of that symbol name. In version 4 you used them like + pointers, but in modern perls you can just use references. + +While there are a few places where you don't actually need these type +specifiers, you should always use them. + +A couple of others that you're likely to encounter that aren't +really type specifiers are: + + <> are used for inputting a record from a filehandle. + \ takes a reference to something. + +Note that E<lt>FILEE<gt> is I<neither> the type specifier for files +nor the name of the handle. It is the C<E<lt>E<gt>> operator applied +to the handle FILE. It reads one line (well, record - see +L<perlvar/$/>) from the handle FILE in scalar context, or I<all> lines +in list context. When performing open, close, or any other operation +besides C<E<lt>E<gt>> on files, or even talking about the handle, do +I<not> use the brackets. These are correct: C<eof(FH)>, C<seek(FH, 0, +2)> and "copying from STDIN to FILE". + +=head2 Do I always/never have to quote my strings or use semicolons and commas? + +Normally, a bareword doesn't need to be quoted, but in most cases +probably should be (and must be under C<use strict>). But a hash key +consisting of a simple word (that isn't the name of a defined +subroutine) and the left-hand operand to the C<=E<gt>> operator both +count as though they were quoted: + + This is like this + ------------ --------------- + $foo{line} $foo{"line"} + bar => stuff "bar" => stuff + +The final semicolon in a block is optional, as is the final comma in a +list. Good style (see L<perlstyle>) says to put them in except for +one-liners: + + if ($whoops) { exit 1 } + @nums = (1, 2, 3); + + if ($whoops) { + exit 1; + } + @lines = ( + "There Beren came from mountains cold", + "And lost he wandered under leaves", + ); + +=head2 How do I skip some return values? + +One way is to treat the return values as a list and index into it: + + $dir = (getpwnam($user))[7]; + +Another way is to use undef as an element on the left-hand-side: + + ($dev, $ino, undef, undef, $uid, $gid) = stat($file); + +=head2 How do I temporarily block warnings? + +The C<$^W> variable (documented in L<perlvar>) controls +runtime warnings for a block: + + { + local $^W = 0; # temporarily turn off warnings + $a = $b + $c; # I know these might be undef + } + +Note that like all the punctuation variables, you cannot currently +use my() on C<$^W>, only local(). + +A new C<use warnings> pragma is in the works to provide finer control +over all this. The curious should check the perl5-porters mailing list +archives for details. + +=head2 What's an extension? + +A way of calling compiled C code from Perl. Reading L<perlxstut> +is a good place to learn more about extensions. + +=head2 Why do Perl operators have different precedence than C operators? + +Actually, they don't. All C operators that Perl copies have the same +precedence in Perl as they do in C. The problem is with operators that C +doesn't have, especially functions that give a list context to everything +on their right, eg print, chmod, exec, and so on. Such functions are +called "list operators" and appear as such in the precedence table in +L<perlop>. + +A common mistake is to write: + + unlink $file || die "snafu"; + +This gets interpreted as: + + unlink ($file || die "snafu"); + +To avoid this problem, either put in extra parentheses or use the +super low precedence C<or> operator: + + (unlink $file) || die "snafu"; + unlink $file or die "snafu"; + +The "English" operators (C<and>, C<or>, C<xor>, and C<not>) +deliberately have precedence lower than that of list operators for +just such situations as the one above. + +Another operator with surprising precedence is exponentiation. It +binds more tightly even than unary minus, making C<-2**2> product a +negative not a positive four. It is also right-associating, meaning +that C<2**3**2> is two raised to the ninth power, not eight squared. + +=head2 How do I declare/create a structure? + +In general, you don't "declare" a structure. Just use a (probably +anonymous) hash reference. See L<perlref> and L<perldsc> for details. +Here's an example: + + $person = {}; # new anonymous hash + $person->{AGE} = 24; # set field AGE to 24 + $person->{NAME} = "Nat"; # set field NAME to "Nat" + +If you're looking for something a bit more rigorous, try L<perltoot>. + +=head2 How do I create a module? + +A module is a package that lives in a file of the same name. For +example, the Hello::There module would live in Hello/There.pm. For +details, read L<perlmod>. You'll also find L<Exporter> helpful. If +you're writing a C or mixed-language module with both C and Perl, then +you should study L<perlxstut>. + +Here's a convenient template you might wish you use when starting your +own module. Make sure to change the names appropriately. + + package Some::Module; # assumes Some/Module.pm + + use strict; + + BEGIN { + use Exporter (); + use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + + ## set the version for version checking; uncomment to use + ## $VERSION = 1.00; + + # if using RCS/CVS, this next line may be preferred, + # but beware two-digit versions. + $VERSION = do{my@r=q$Revision: 1.18 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r}; + + @ISA = qw(Exporter); + @EXPORT = qw(&func1 &func2 &func3); + %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ], + + # your exported package globals go here, + # as well as any optionally exported functions + @EXPORT_OK = qw($Var1 %Hashit); + } + use vars @EXPORT_OK; + + # non-exported package globals go here + use vars qw( @more $stuff ); + + # initialize package globals, first exported ones + $Var1 = ''; + %Hashit = (); + + # then the others (which are still accessible as $Some::Module::stuff) + $stuff = ''; + @more = (); + + # all file-scoped lexicals must be created before + # the functions below that use them. + + # file-private lexicals go here + my $priv_var = ''; + my %secret_hash = (); + + # here's a file-private function as a closure, + # callable as &$priv_func; it cannot be prototyped. + my $priv_func = sub { + # stuff goes here. + }; + + # make all your functions, whether exported or not; + # remember to put something interesting in the {} stubs + sub func1 {} # no prototype + sub func2() {} # proto'd void + sub func3($$) {} # proto'd to 2 scalars + + # this one isn't exported, but could be called! + sub func4(\%) {} # proto'd to 1 hash ref + + END { } # module clean-up code here (global destructor) + + 1; # modules must return true + +=head2 How do I create a class? + +See L<perltoot> for an introduction to classes and objects, as well as +L<perlobj> and L<perlbot>. + +=head2 How can I tell if a variable is tainted? + +See L<perlsec/"Laundering and Detecting Tainted Data">. Here's an +example (which doesn't use any system calls, because the kill() +is given no processes to signal): + + sub is_tainted { + return ! eval { join('',@_), kill 0; 1; }; + } + +This is not C<-w> clean, however. There is no C<-w> clean way to +detect taintedness - take this as a hint that you should untaint +all possibly-tainted data. + +=head2 What's a closure? + +Closures are documented in L<perlref>. + +I<Closure> is a computer science term with a precise but +hard-to-explain meaning. Closures are implemented in Perl as anonymous +subroutines with lasting references to lexical variables outside their +own scopes. These lexicals magically refer to the variables that were +around when the subroutine was defined (deep binding). + +Closures make sense in any programming language where you can have the +return value of a function be itself a function, as you can in Perl. +Note that some languages provide anonymous functions but are not +capable of providing proper closures; the Python language, for +example. For more information on closures, check out any textbook on +functional programming. Scheme is a language that not only supports +but encourages closures. + +Here's a classic function-generating function: + + sub add_function_generator { + return sub { shift + shift }; + } + + $add_sub = add_function_generator(); + $sum = &$add_sub(4,5); # $sum is 9 now. + +The closure works as a I<function template> with some customization +slots left out to be filled later. The anonymous subroutine returned +by add_function_generator() isn't technically a closure because it +refers to no lexicals outside its own scope. + +Contrast this with the following make_adder() function, in which the +returned anonymous function contains a reference to a lexical variable +outside the scope of that function itself. Such a reference requires +that Perl return a proper closure, thus locking in for all time the +value that the lexical had when the function was created. + + sub make_adder { + my $addpiece = shift; + return sub { shift + $addpiece }; + } + + $f1 = make_adder(20); + $f2 = make_adder(555); + +Now C<&$f1($n)> is always 20 plus whatever $n you pass in, whereas +C<&$f2($n)> is always 555 plus whatever $n you pass in. The $addpiece +in the closure sticks around. + +Closures are often used for less esoteric purposes. For example, when +you want to pass in a bit of code into a function: + + my $line; + timeout( 30, sub { $line = <STDIN> } ); + +If the code to execute had been passed in as a string, C<'$line = +E<lt>STDINE<gt>'>, there would have been no way for the hypothetical +timeout() function to access the lexical variable $line back in its +caller's scope. + +=head2 What is variable suicide and how can I prevent it? + +Variable suicide is when you (temporarily or permanently) lose the +value of a variable. It is caused by scoping through my() and local() +interacting with either closures or aliased foreach() interator +variables and subroutine arguments. It used to be easy to +inadvertently lose a variable's value this way, but now it's much +harder. Take this code: + + my $f = "foo"; + sub T { + while ($i++ < 3) { my $f = $f; $f .= "bar"; print $f, "\n" } + } + T; + print "Finally $f\n"; + +The $f that has "bar" added to it three times should be a new C<$f> +(C<my $f> should create a new local variable each time through the +loop). It isn't, however. This is a bug, and will be fixed. + +=head2 How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regexp}? + +With the exception of regexps, you need to pass references to these +objects. See L<perlsub/"Pass by Reference"> for this particular +question, and L<perlref> for information on references. + +=over 4 + +=item Passing Variables and Functions + +Regular variables and functions are quite easy: just pass in a +reference to an existing or anonymous variable or function: + + func( \$some_scalar ); + + func( \$some_array ); + func( [ 1 .. 10 ] ); + + func( \%some_hash ); + func( { this => 10, that => 20 } ); + + func( \&some_func ); + func( sub { $_[0] ** $_[1] } ); + +=item Passing Filehandles + +To create filehandles you can pass to subroutines, you can use C<*FH> +or C<\*FH> notation ("typeglobs" - see L<perldata> for more information), +or create filehandles dynamically using the old FileHandle or the new +IO::File modules, both part of the standard Perl distribution. + + use Fcntl; + use IO::File; + my $fh = new IO::File $filename, O_WRONLY|O_APPEND; + or die "Can't append to $filename: $!"; + func($fh); + +=item Passing Regexps + +To pass regexps around, you'll need to either use one of the highly +experimental regular expression modules from CPAN (Nick Ing-Simmons's +Regexp or Ilya Zakharevich's Devel::Regexp), pass around strings +and use an exception-trapping eval, or else be be very, very clever. +Here's an example of how to pass in a string to be regexp compared: + + sub compare($$) { + my ($val1, $regexp) = @_; + my $retval = eval { $val =~ /$regexp/ }; + die if $@; + return $retval; + } + + $match = compare("old McDonald", q/d.*D/); + +Make sure you never say something like this: + + return eval "\$val =~ /$regexp/"; # WRONG + +or someone can sneak shell escapes into the regexp due to the double +interpolation of the eval and the double-quoted string. For example: + + $pattern_of_evil = 'danger ${ system("rm -rf * &") } danger'; + + eval "\$string =~ /$pattern_of_evil/"; + +Those preferring to be very, very clever might see the O'Reilly book, +I<Mastering Regular Expressions>, by Jeffrey Friedl. Page 273's +Build_MatchMany_Function() is particularly interesting. A complete +citation of this book is given in L<perlfaq2>. + +=item Passing Methods + +To pass an object method into a subroutine, you can do this: + + call_a_lot(10, $some_obj, "methname") + sub call_a_lot { + my ($count, $widget, $trick) = @_; + for (my $i = 0; $i < $count; $i++) { + $widget->$trick(); + } + } + +or you can use a closure to bundle up the object and its method call +and arguments: + + my $whatnot = sub { $some_obj->obfuscate(@args) }; + func($whatnot); + sub func { + my $code = shift; + &$code(); + } + +You could also investigate the can() method in the UNIVERSAL class +(part of the standard perl distribution). + +=back + +=head2 How do I create a static variable? + +As with most things in Perl, TMTOWTDI. What is a "static variable" in +other languages could be either a function-private variable (visible +only within a single function, retaining its value between calls to +that function), or a file-private variable (visible only to functions +within the file it was declared in) in Perl. + +Here's code to implement a function-private variable: + + BEGIN { + my $counter = 42; + sub prev_counter { return --$counter } + sub next_counter { return $counter++ } + } + +Now prev_counter() and next_counter() share a private variable $counter +that was initialized at compile time. + +To declare a file-private variable, you'll still use a my(), putting +it at the outer scope level at the top of the file. Assume this is in +file Pax.pm: + + package Pax; + my $started = scalar(localtime(time())); + + sub begun { return $started } + +When C<use Pax> or C<require Pax> loads this module, the variable will +be initialized. It won't get garbage-collected the way most variables +going out of scope do, because the begun() function cares about it, +but no one else can get it. It is not called $Pax::started because +its scope is unrelated to the package. It's scoped to the file. You +could conceivably have several packages in that same file all +accessing the same private variable, but another file with the same +package couldn't get to it. + +=head2 What's the difference between dynamic and lexical (static) scoping? Between local() and my()? + +C<local($x)> saves away the old value of the global variable C<$x>, +and assigns a new value for the duration of the subroutine, I<which is +visible in other functions called from that subroutine>. This is done +at run-time, so is called dynamic scoping. local() always affects global +variables, also called package variables or dynamic variables. + +C<my($x)> creates a new variable that is only visible in the current +subroutine. This is done at compile-time, so is called lexical or +static scoping. my() always affects private variables, also called +lexical variables or (improperly) static(ly scoped) variables. + +For instance: + + sub visible { + print "var has value $var\n"; + } + + sub dynamic { + local $var = 'local'; # new temporary value for the still-global + visible(); # variable called $var + } + + sub lexical { + my $var = 'private'; # new private variable, $var + visible(); # (invisible outside of sub scope) + } + + $var = 'global'; + + visible(); # prints global + dynamic(); # prints local + lexical(); # prints global + +Notice how at no point does the value "private" get printed. That's +because $var only has that value within the block of the lexical() +function, and it is hidden from called subroutine. + +In summary, local() doesn't make what you think of as private, local +variables. It gives a global variable a temporary value. my() is +what you're looking for if you want private variables. + +See also L<perlsub>, which explains this all in more detail. + +=head2 How can I access a dynamic variable while a similarly named lexical is in scope? + +You can do this via symbolic references, provided you haven't set +C<use strict "refs">. So instead of $var, use C<${'var'}>. + + local $var = "global"; + my $var = "lexical"; + + print "lexical is $var\n"; + + no strict 'refs'; + print "global is ${'var'}\n"; + +If you know your package, you can just mention it explicitly, as in +$Some_Pack::var. Note that the notation $::var is I<not> the dynamic +$var in the current package, but rather the one in the C<main> +package, as though you had written $main::var. Specifying the package +directly makes you hard-code its name, but it executes faster and +avoids running afoul of C<use strict "refs">. + +=head2 What's the difference between deep and shallow binding? + +In deep binding, lexical variables mentioned in anonymous subroutines +are the same ones that were in scope when the subroutine was created. +In shallow binding, they are whichever variables with the same names +happen to be in scope when the subroutine is called. Perl always uses +deep binding of lexical variables (i.e., those created with my()). +However, dynamic variables (aka global, local, or package variables) +are effectively shallowly bound. Consider this just one more reason +not to use them. See the answer to L<"What's a closure?">. + +=head2 Why doesn't "local($foo) = <FILE>;" work right? + +C<local()> gives list context to the right hand side of C<=>. The +E<lt>FHE<gt> read operation, like so many of Perl's functions and +operators, can tell which context it was called in and behaves +appropriately. In general, the scalar() function can help. This +function does nothing to the data itself (contrary to popular myth) +but rather tells its argument to behave in whatever its scalar fashion +is. If that function doesn't have a defined scalar behavior, this of +course doesn't help you (such as with sort()). + +To enforce scalar context in this particular case, however, you need +merely omit the parentheses: + + local($foo) = <FILE>; # WRONG + local($foo) = scalar(<FILE>); # ok + local $foo = <FILE>; # right + +You should probably be using lexical variables anyway, although the +issue is the same here: + + my($foo) = <FILE>; # WRONG + my $foo = <FILE>; # right + +=head2 How do I redefine a builtin function, operator, or method? + +Why do you want to do that? :-) + +If you want to override a predefined function, such as open(), +then you'll have to import the new definition from a different +module. See L<perlsub/"Overriding Builtin Functions">. There's +also an example in L<perltoot/"Class::Template">. + +If you want to overload a Perl operator, such as C<+> or C<**>, +then you'll want to use the C<use overload> pragma, documented +in L<overload>. + +If you're talking about obscuring method calls in parent classes, +see L<perltoot/"Overridden Methods">. + +=head2 What's the difference between calling a function as &foo and foo()? + +When you call a function as C<&foo>, you allow that function access to +your current @_ values, and you by-pass prototypes. That means that +the function doesn't get an empty @_, it gets yours! While not +strictly speaking a bug (it's documented that way in L<perlsub>), it +would be hard to consider this a feature in most cases. + +When you call your function as C<&foo()>, then you do get a new @_, +but prototyping is still circumvented. + +Normally, you want to call a function using C<foo()>. You may only +omit the parentheses if the function is already known to the compiler +because it already saw the definition (C<use> but not C<require>), +or via a forward reference or C<use subs> declaration. Even in this +case, you get a clean @_ without any of the old values leaking through +where they don't belong. + +=head2 How do I create a switch or case statement? + +This is explained in more depth in the L<perlsyn>. Briefly, there's +no official case statement, because of the variety of tests possible +in Perl (numeric comparison, string comparison, glob comparison, +regexp matching, overloaded comparisons, ...). Larry couldn't decide +how best to do this, so he left it out, even though it's been on the +wish list since perl1. + +Here's a simple example of a switch based on pattern matching. We'll +do a multi-way conditional based on the type of reference stored in +$whatchamacallit: + + SWITCH: + for (ref $whatchamacallit) { + + /^$/ && die "not a reference"; + + /SCALAR/ && do { + print_scalar($$ref); + last SWITCH; + }; + + /ARRAY/ && do { + print_array(@$ref); + last SWITCH; + }; + + /HASH/ && do { + print_hash(%$ref); + last SWITCH; + }; + + /CODE/ && do { + warn "can't print function ref"; + last SWITCH; + }; + + # DEFAULT + + warn "User defined type skipped"; + + } + +=head2 How can I catch accesses to undefined variables/functions/methods? + +The AUTOLOAD method, discussed in L<perlsub/"Autoloading"> and +L<perltoot/"AUTOLOAD: Proxy Methods">, lets you capture calls to +undefined functions and methods. + +When it comes to undefined variables that would trigger a warning +under C<-w>, you can use a handler to trap the pseudo-signal +C<__WARN__> like this: + + $SIG{__WARN__} = sub { + + for ( $_[0] ) { + + /Use of uninitialized value/ && do { + # promote warning to a fatal + die $_; + }; + + # other warning cases to catch could go here; + + warn $_; + } + + }; + +=head2 Why can't a method included in this same file be found? + +Some possible reasons: your inheritance is getting confused, you've +misspelled the method name, or the object is of the wrong type. Check +out L<perltoot> for details on these. You may also use C<print +ref($object)> to find out the class C<$object> was blessed into. + +Another possible reason for problems is because you've used the +indirect object syntax (eg, C<find Guru "Samy">) on a class name +before Perl has seen that such a package exists. It's wisest to make +sure your packages are all defined before you start using them, which +will be taken care of if you use the C<use> statement instead of +C<require>. If not, make sure to use arrow notation (eg, +C<Guru->find("Samy")>) instead. Object notation is explained in +L<perlobj>. + +=head2 How can I find out my current package? + +If you're just a random program, you can do this to find +out what the currently compiled package is: + + my $packname = ref bless []; + +But if you're a method and you want to print an error message +that includes the kind of object you were called on (which is +not necessarily the same as the one in which you were compiled): + + sub amethod { + my $self = shift; + my $class = ref($self) || $self; + warn "called me from a $class object"; + } + +=head2 How can I comment out a large block of perl code? + +Use embedded POD to discard it: + + # program is here + + =for nobody + This paragraph is commented out + + # program continues + + =begin comment text + + all of this stuff + + here will be ignored + by everyone + + =end comment text + + =cut + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. diff --git a/gnu/usr.bin/perl/pod/perlfaq8.pod b/gnu/usr.bin/perl/pod/perlfaq8.pod new file mode 100644 index 00000000000..f4d3c12f6f7 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq8.pod @@ -0,0 +1,851 @@ +=head1 NAME + +perlfaq8 - System Interaction ($Revision: 1.21 $, $Date: 1997/04/24 22:44:19 $) + +=head1 DESCRIPTION + +This section of the Perl FAQ covers questions involving operating +system interaction. This involves interprocess communication (IPC), +control over the user-interface (keyboard, screen and pointing +devices), and most anything else not related to data manipulation. + +Read the FAQs and documentation specific to the port of perl to your +operating system (eg, L<perlvms>, L<perlplan9>, ...). These should +contain more detailed information on the vagaries of your perl. + +=head2 How do I find out which operating system I'm running under? + +The $^O variable ($OSTYPE if you use English) contains the operating +system that your perl binary was built for. + +=head2 How come exec() doesn't return? + +Because that's what it does: it replaces your currently running +program with a different one. If you want to keep going (as is +probably the case if you're asking this question) use system() +instead. + +=head2 How do I do fancy stuff with the keyboard/screen/mouse? + +How you access/control keyboards, screens, and pointing devices +("mice") is system-dependent. Try the following modules: + +=over 4 + +=item Keyboard + + Term::Cap Standard perl distribution + Term::ReadKey CPAN + Term::ReadLine::Gnu CPAN + Term::ReadLine::Perl CPAN + Term::Screen CPAN + +=item Screen + + Term::Cap Standard perl distribution + Curses CPAN + Term::ANSIColor CPAN + +=item Mouse + + Tk CPAN + +=back + +=head2 How do I ask the user for a password? + +(This question has nothing to do with the web. See a different +FAQ for that.) + +There's an example of this in L<perlfunc/crypt>). First, you put +the terminal into "no echo" mode, then just read the password +normally. You may do this with an old-style ioctl() function, POSIX +terminal control (see L<POSIX>, and Chapter 7 of the Camel), or a call +to the B<stty> program, with varying degrees of portability. + +You can also do this for most systems using the Term::ReadKey module +from CPAN, which is easier to use and in theory more portable. + +=head2 How do I read and write the serial port? + +This depends on which operating system your program is running on. In +the case of Unix, the serial ports will be accessible through files in +/dev; on other systems, the devices names will doubtless differ. +Several problem areas common to all device interaction are the +following + +=over 4 + +=item lockfiles + +Your system may use lockfiles to control multiple access. Make sure +you follow the correct protocol. Unpredictable behaviour can result +from multiple processes reading from one device. + +=item open mode + +If you expect to use both read and write operations on the device, +you'll have to open it for update (see L<perlfunc/"open"> for +details). You may wish to open it without running the risk of +blocking by using sysopen() and C<O_RDWR|O_NDELAY|O_NOCTTY> from the +Fcntl module (part of the standard perl distribution). See +L<perlfunc/"sysopen"> for more on this approach. + +=item end of line + +Some devices will be expecting a "\r" at the end of each line rather +than a "\n". In some ports of perl, "\r" and "\n" are different from +their usual (Unix) ASCII values of "\012" and "\015". You may have to +give the numeric values you want directly, using octal ("\015"), hex +("0x0D"), or as a control-character specification ("\cM"). + + print DEV "atv1\012"; # wrong, for some devices + print DEV "atv1\015"; # right, for some devices + +Even though with normal text files, a "\n" will do the trick, there is +still no unified scheme for terminating a line that is portable +between Unix, DOS/Win, and Macintosh, except to terminate I<ALL> line +ends with "\015\012", and strip what you don't need from the output. +This applies especially to socket I/O and autoflushing, discussed +next. + +=item flushing output + +If you expect characters to get to your device when you print() them, +you'll want to autoflush that filehandle, as in the older + + use FileHandle; + DEV->autoflush(1); + +and the newer + + use IO::Handle; + DEV->autoflush(1); + +You can use select() and the C<$|> variable to control autoflushing +(see L<perlvar/$|> and L<perlfunc/select>): + + $oldh = select(DEV); + $| = 1; + select($oldh); + +You'll also see code that does this without a temporary variable, as in + + select((select(DEV), $| = 1)[0]); + +As mentioned in the previous item, this still doesn't work when using +socket I/O between Unix and Macintosh. You'll need to hardcode your +line terminators, in that case. + +=item non-blocking input + +If you are doing a blocking read() or sysread(), you'll have to +arrange for an alarm handler to provide a timeout (see +L<perlfunc/alarm>). If you have a non-blocking open, you'll likely +have a non-blocking read, which means you may have to use a 4-arg +select() to determine whether I/O is ready on that device (see +L<perlfunc/"select">. + +=back + +=head2 How do I decode encrypted password files? + +You spend lots and lots of money on dedicated hardware, but this is +bound to get you talked about. + +Seriously, you can't if they are Unix password files - the Unix +password system employs one-way encryption. Programs like Crack can +forcibly (and intelligently) try to guess passwords, but don't (can't) +guarantee quick success. + +If you're worried about users selecting bad passwords, you should +proactively check when they try to change their password (by modifying +passwd(1), for example). + +=head2 How do I start a process in the background? + +You could use + + system("cmd &") + +or you could use fork as documented in L<perlfunc/"fork">, with +further examples in L<perlipc>. Some things to be aware of, if you're +on a Unix-like system: + +=over 4 + +=item STDIN, STDOUT and STDERR are shared + +Both the main process and the backgrounded one (the "child" process) +share the same STDIN, STDOUT and STDERR filehandles. If both try to +access them at once, strange things can happen. You may want to close +or reopen these for the child. You can get around this with +C<open>ing a pipe (see L<perlfunc/"open">) but on some systems this +means that the child process cannot outlive the parent. + +=item Signals + +You'll have to catch the SIGCHLD signal, and possibly SIGPIPE too. +SIGCHLD is sent when the backgrounded process finishes. SIGPIPE is +sent when you write to a filehandle whose child process has closed (an +untrapped SIGPIPE can cause your program to silently die). This is +not an issue with C<system("cmd&")>. + +=item Zombies + +You have to be prepared to "reap" the child process when it finishes + + $SIG{CHLD} = sub { wait }; + +See L<perlipc/"Signals"> for other examples of code to do this. +Zombies are not an issue with C<system("prog &")>. + +=back + +=head2 How do I trap control characters/signals? + +You don't actually "trap" a control character. Instead, that +character generates a signal, which you then trap. Signals are +documented in L<perlipc/"Signals"> and chapter 6 of the Camel. + +Be warned that very few C libraries are re-entrant. Therefore, if you +attempt to print() in a handler that got invoked during another stdio +operation your internal structures will likely be in an +inconsistent state, and your program will dump core. You can +sometimes avoid this by using syswrite() instead of print(). + +Unless you're exceedingly careful, the only safe things to do inside a +signal handler are: set a variable and exit. And in the first case, +you should only set a variable in such a way that malloc() is not +called (eg, by setting a variable that already has a value). + +For example: + + $Interrupted = 0; # to ensure it has a value + $SIG{INT} = sub { + $Interrupted++; + syswrite(STDERR, "ouch\n", 5); + } + +However, because syscalls restart by default, you'll find that if +you're in a "slow" call, such as E<lt>FHE<gt>, read(), connect(), or +wait(), that the only way to terminate them is by "longjumping" out; +that is, by raising an exception. See the time-out handler for a +blocking flock() in L<perlipc/"Signals"> or chapter 6 of the Camel. + +=head2 How do I modify the shadow password file on a Unix system? + +If perl was installed correctly, the getpw*() functions described in +L<perlfunc> provide (read-only) access to the shadow password file. +To change the file, make a new shadow password file (the format varies +from system to system - see L<passwd(5)> for specifics) and use +pwd_mkdb(8) to install it (see L<pwd_mkdb(5)> for more details). + +=head2 How do I set the time and date? + +Assuming you're running under sufficient permissions, you should be +able to set the system-wide date and time by running the date(1) +program. (There is no way to set the time and date on a per-process +basis.) This mechanism will work for Unix, MS-DOS, Windows, and NT; +the VMS equivalent is C<set time>. + +However, if all you want to do is change your timezone, you can +probably get away with setting an environment variable: + + $ENV{TZ} = "MST7MDT"; # unixish + $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}="-5" # vms + system "trn comp.lang.perl"; + +=head2 How can I sleep() or alarm() for under a second? + +If you want finer granularity than the 1 second that the sleep() +function provides, the easiest way is to use the select() function as +documented in L<perlfunc/"select">. If your system has itimers and +syscall() support, you can check out the old example in +http://www.perl.com/CPAN/doc/misc/ancient/tutorial/eg/itimers.pl . + +=head2 How can I measure time under a second? + +In general, you may not be able to. The Time::HiRes module (available +from CPAN) provides this functionality for some systems. + +In general, you may not be able to. But if you system supports both the +syscall() function in Perl as well as a system call like gettimeofday(2), +then you may be able to do something like this: + + require 'sys/syscall.ph'; + + $TIMEVAL_T = "LL"; + + $done = $start = pack($TIMEVAL_T, ()); + + syscall( &SYS_gettimeofday, $start, 0)) != -1 + or die "gettimeofday: $!"; + + ########################## + # DO YOUR OPERATION HERE # + ########################## + + syscall( &SYS_gettimeofday, $done, 0) != -1 + or die "gettimeofday: $!"; + + @start = unpack($TIMEVAL_T, $start); + @done = unpack($TIMEVAL_T, $done); + + # fix microseconds + for ($done[1], $start[1]) { $_ /= 1_000_000 } + + $delta_time = sprintf "%.4f", ($done[0] + $done[1] ) + - + ($start[0] + $start[1] ); + +=head2 How can I do an atexit() or setjmp()/longjmp()? (Exception handling) + +Release 5 of Perl added the END block, which can be used to simulate +atexit(). Each package's END block is called when the program or +thread ends (see L<perlmod> manpage for more details). It isn't +called when untrapped signals kill the program, though, so if you use +END blocks you should also use + + use sigtrap qw(die normal-signals); + +Perl's exception-handling mechanism is its eval() operator. You can +use eval() as setjmp and die() as longjmp. For details of this, see +the section on signals, especially the time-out handler for a blocking +flock() in L<perlipc/"Signals"> and chapter 6 of the Camel. + +If exception handling is all you're interested in, try the +exceptions.pl library (part of the standard perl distribution). + +If you want the atexit() syntax (and an rmexit() as well), try the +AtExit module available from CPAN. + +=head2 Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean? + +Some Sys-V based systems, notably Solaris 2.X, redefined some of the +standard socket constants. Since these were constant across all +architectures, they were often hardwired into perl code. The proper +way to deal with this is to "use Socket" to get the correct values. + +Note that even though SunOS and Solaris are binary compatible, these +values are different. Go figure. + +=head2 How can I call my system's unique C functions from Perl? + +In most cases, you write an external module to do it - see the answer +to "Where can I learn about linking C with Perl? [h2xs, xsubpp]". +However, if the function is a system call, and your system supports +syscall(), you can use the syscall function (documented in +L<perlfunc>). + +Remember to check the modules that came with your distribution, and +CPAN as well - someone may already have written a module to do it. + +=head2 Where do I get the include files to do ioctl() or syscall()? + +Historically, these would be generated by the h2ph tool, part of the +standard perl distribution. This program converts cpp(1) directives +in C header files to files containing subroutine definitions, like +&SYS_getitimer, which you can use as arguments to your functions. +It doesn't work perfectly, but it usually gets most of the job done. +Simple files like F<errno.h>, F<syscall.h>, and F<socket.h> were fine, +but the hard ones like F<ioctl.h> nearly always need to hand-edited. +Here's how to install the *.ph files: + + 1. become super-user + 2. cd /usr/include + 3. h2ph *.h */*.h + +If your system supports dynamic loading, for reasons of portability and +sanity you probably ought to use h2xs (also part of the standard perl +distribution). This tool converts C header files to Perl extensions. +See L<perlxstut> for how to get started with h2xs. + +If your system doesn't support dynamic loading, you still probably +ought to use h2xs. See L<perlxstut> and L<ExtUtils::MakeMaker> for +more information (in brief, just use B<make perl> instead of a plain +B<make> to rebuild perl with a new static extension). + +=head2 Why do setuid perl scripts complain about kernel problems? + +Some operating systems have bugs in the kernel that make setuid +scripts inherently insecure. Perl gives you a number of options +(described in L<perlsec>) to work around such systems. + +=head2 How can I open a pipe both to and from a command? + +The IPC::Open2 module (part of the standard perl distribution) is an +easy-to-use approach that internally uses pipe(), fork(), and exec() +to do the job. Make sure you read the deadlock warnings in its +documentation, though (see L<IPC::Open2>). + +=head2 Why can't I get the output of a command with system()? + +You're confusing the purpose of system() and backticks (``). system() +runs a command and returns exit status information (as a 16 bit value: +the low 8 bits are the signal the process died from, if any, and +the high 8 bits are the actual exit value). Backticks (``) run a +command and return what it sent to STDOUT. + + $exit_status = system("mail-users"); + $output_string = `ls`; + +=head2 How can I capture STDERR from an external command? + +There are three basic ways of running external commands: + + system $cmd; # using system() + $output = `$cmd`; # using backticks (``) + open (PIPE, "cmd |"); # using open() + +With system(), both STDOUT and STDERR will go the same place as the +script's versions of these, unless the command redirects them. +Backticks and open() read B<only> the STDOUT of your command. + +With any of these, you can change file descriptors before the call: + + open(STDOUT, ">logfile"); + system("ls"); + +or you can use Bourne shell file-descriptor redirection: + + $output = `$cmd 2>some_file`; + open (PIPE, "cmd 2>some_file |"); + +You can also use file-descriptor redirection to make STDERR a +duplicate of STDOUT: + + $output = `$cmd 2>&1`; + open (PIPE, "cmd 2>&1 |"); + +Note that you I<cannot> simply open STDERR to be a dup of STDOUT +in your Perl program and avoid calling the shell to do the redirection. +This doesn't work: + + open(STDERR, ">&STDOUT"); + $alloutput = `cmd args`; # stderr still escapes + +This fails because the open() makes STDERR go to where STDOUT was +going at the time of the open(). The backticks then make STDOUT go to +a string, but don't change STDERR (which still goes to the old +STDOUT). + +Note that you I<must> use Bourne shell (sh(1)) redirection syntax in +backticks, not csh(1)! Details on why Perl's system() and backtick +and pipe opens all use the Bourne shell are in +http://www.perl.com/CPAN/doc/FMTEYEWTK/versus/csh.whynot . + +You may also use the IPC::Open3 module (part of the standard perl +distribution), but be warned that it has a different order of +arguments from IPC::Open2 (see L<IPC::Open3>). + +=head2 Why doesn't open() return an error when a pipe open fails? + +It does, but probably not how you expect it to. On systems that +follow the standard fork()/exec() paradigm (eg, Unix), it works like +this: open() causes a fork(). In the parent, open() returns with the +process ID of the child. The child exec()s the command to be piped +to/from. The parent can't know whether the exec() was successful or +not - all it can return is whether the fork() succeeded or not. To +find out if the command succeeded, you have to catch SIGCHLD and +wait() to get the exit status. You should also catch SIGPIPE if +you're writing to the child -- you may not have found out the exec() +failed by the time you write. This is documented in L<perlipc>. + +On systems that follow the spawn() paradigm, open() I<might> do what +you expect - unless perl uses a shell to start your command. In this +case the fork()/exec() description still applies. + +=head2 What's wrong with using backticks in a void context? + +Strictly speaking, nothing. Stylistically speaking, it's not a good +way to write maintainable code because backticks have a (potentially +humungous) return value, and you're ignoring it. It's may also not be very +efficient, because you have to read in all the lines of output, allocate +memory for them, and then throw it away. Too often people are lulled +to writing: + + `cp file file.bak`; + +And now they think "Hey, I'll just always use backticks to run programs." +Bad idea: backticks are for capturing a program's output; the system() +function is for running programs. + +Consider this line: + + `cat /etc/termcap`; + +You haven't assigned the output anywhere, so it just wastes memory +(for a little while). Plus you forgot to check C<$?> to see whether +the program even ran correctly. Even if you wrote + + print `cat /etc/termcap`; + +In most cases, this could and probably should be written as + + system("cat /etc/termcap") == 0 + or die "cat program failed!"; + +Which will get the output quickly (as its generated, instead of only +at the end ) and also check the return value. + +system() also provides direct control over whether shell wildcard +processing may take place, whereas backticks do not. + +=head2 How can I call backticks without shell processing? + +This is a bit tricky. Instead of writing + + @ok = `grep @opts '$search_string' @filenames`; + +You have to do this: + + my @ok = (); + if (open(GREP, "-|")) { + while (<GREP>) { + chomp; + push(@ok, $_); + } + close GREP; + } else { + exec 'grep', @opts, $search_string, @filenames; + } + +Just as with system(), no shell escapes happen when you exec() a list. + +=head2 Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)? + +Because some stdio's set error and eof flags that need clearing. The +POSIX module defines clearerr() that you can use. That is the +technically correct way to do it. Here are some less reliable +workarounds: + +=over 4 + +=item 1 + +Try keeping around the seekpointer and go there, like this: + + $where = tell(LOG); + seek(LOG, $where, 0); + +=item 2 + +If that doesn't work, try seeking to a different part of the file and +then back. + +=item 3 + +If that doesn't work, try seeking to a different part of +the file, reading something, and then seeking back. + +=item 4 + +If that doesn't work, give up on your stdio package and use sysread. + +=back + +=head2 How can I convert my shell script to perl? + +Learn Perl and rewrite it. Seriously, there's no simple converter. +Things that are awkward to do in the shell are easy to do in Perl, and +this very awkwardness is what would make a shell->perl converter +nigh-on impossible to write. By rewriting it, you'll think about what +you're really trying to do, and hopefully will escape the shell's +pipeline datastream paradigm, which while convenient for some matters, +causes many inefficiencies. + +=head2 Can I use perl to run a telnet or ftp session? + +Try the Net::FTP, TCP::Client, and Net::Telnet modules (available from +CPAN). http://www.perl.com/CPAN/scripts/netstuff/telnet.emul.shar +will also help for emulating the telnet protocol, but Net::Telnet is +quite probably easier to use.. + +If all you want to do is pretend to be telnet but don't need +the initial telnet handshaking, then the standard dual-process +approach will suffice: + + use IO::Socket; # new in 5.004 + $handle = IO::Socket::INET->new('www.perl.com:80') + || die "can't connect to port 80 on www.perl.com: $!"; + $handle->autoflush(1); + if (fork()) { # XXX: undef means failure + select($handle); + print while <STDIN>; # everything from stdin to socket + } else { + print while <$handle>; # everything from socket to stdout + } + close $handle; + exit; + +=head2 How can I write expect in Perl? + +Once upon a time, there was a library called chat2.pl (part of the +standard perl distribution), which never really got finished. These +days, your best bet is to look at the Comm.pl library available from +CPAN. + +=head2 Is there a way to hide perl's command line from programs such as "ps"? + +First of all note that if you're doing this for security reasons (to +avoid people seeing passwords, for example) then you should rewrite +your program so that critical information is never given as an +argument. Hiding the arguments won't make your program completely +secure. + +To actually alter the visible command line, you can assign to the +variable $0 as documented in L<perlvar>. This won't work on all +operating systems, though. Daemon programs like sendmail place their +state there, as in: + + $0 = "orcus [accepting connections]"; + +=head2 I {changed directory, modified my environment} in a perl script. How come the change disappeared when I exited the script? How do I get my changes to be visible? + +=over 4 + +=item Unix + +In the strictest sense, it can't be done -- the script executes as a +different process from the shell it was started from. Changes to a +process are not reflected in its parent, only in its own children +created after the change. There is shell magic that may allow you to +fake it by eval()ing the script's output in your shell; check out the +comp.unix.questions FAQ for details. + +=item VMS + +Change to %ENV persist after Perl exits, but directory changes do not. + +=back + +=head2 How do I close a process's filehandle without waiting for it to complete? + +Assuming your system supports such things, just send an appropriate signal +to the process (see L<perlfunc/"kill">. It's common to first send a TERM +signal, wait a little bit, and then send a KILL signal to finish it off. + +=head2 How do I fork a daemon process? + +If by daemon process you mean one that's detached (disassociated from +its tty), then the following process is reported to work on most +Unixish systems. Non-Unix users should check their Your_OS::Process +module for other solutions. + +=over 4 + +=item * + +Open /dev/tty and use the the TIOCNOTTY ioctl on it. See L<tty(4)> +for details. + +=item * + +Change directory to / + +=item * + +Reopen STDIN, STDOUT, and STDERR so they're not connected to the old +tty. + +=item * + +Background yourself like this: + + fork && exit; + +=back + +=head2 How do I make my program run with sh and csh? + +See the F<eg/nih> script (part of the perl source distribution). + +=head2 How do I find out if I'm running interactively or not? + +Good question. Sometimes C<-t STDIN> and C<-t STDOUT> can give clues, +sometimes not. + + if (-t STDIN && -t STDOUT) { + print "Now what? "; + } + +On POSIX systems, you can test whether your own process group matches +the current process group of your controlling terminal as follows: + + use POSIX qw/getpgrp tcgetpgrp/; + open(TTY, "/dev/tty") or die $!; + $tpgrp = tcgetpgrp(TTY); + $pgrp = getpgrp(); + if ($tpgrp == $pgrp) { + print "foreground\n"; + } else { + print "background\n"; + } + +=head2 How do I timeout a slow event? + +Use the alarm() function, probably in conjunction with a signal +handler, as documented L<perlipc/"Signals"> and chapter 6 of the +Camel. You may instead use the more flexible Sys::AlarmCall module +available from CPAN. + +=head2 How do I set CPU limits? + +Use the BSD::Resource module from CPAN. + +=head2 How do I avoid zombies on a Unix system? + +Use the reaper code from L<perlipc/"Signals"> to call wait() when a +SIGCHLD is received, or else use the double-fork technique described +in L<perlfunc/fork>. + +=head2 How do I use an SQL database? + +There are a number of excellent interfaces to SQL databases. See the +DBD::* modules available from +http://www.perl.com/CPAN/modules/dbperl/DBD . + +=head2 How do I make a system() exit on control-C? + +You can't. You need to imitate the system() call (see L<perlipc> for +sample code) and then have a signal handler for the INT signal that +passes the signal on to the subprocess. + +=head2 How do I open a file without blocking? + +If you're lucky enough to be using a system that supports +non-blocking reads (most Unixish systems do), you need only to use the +O_NDELAY or O_NONBLOCK flag from the Fcntl module in conjunction with +sysopen(): + + use Fcntl; + sysopen(FH, "/tmp/somefile", O_WRONLY|O_NDELAY|O_CREAT, 0644) + or die "can't open /tmp/somefile: $!": + +=head2 How do I install a CPAN module? + +The easiest way is to have the CPAN module do it for you. This module +comes with perl version 5.004 and later. To manually install the CPAN +module, or any well-behaved CPAN module for that matter, follow these +steps: + +=over 4 + +=item 1 + +Unpack the source into a temporary area. + +=item 2 + + perl Makefile.PL + +=item 3 + + make + +=item 4 + + make test + +=item 5 + + make install + +=back + +If your version of perl is compiled without dynamic loading, then you +just need to replace step 3 (B<make>) with B<make perl> and you will +get a new F<perl> binary with your extension linked in. + +See L<ExtUtils::MakeMaker> for more details on building extensions, +the question "How do I keep my own module/library directory?" + +=head2 How do I keep my own module/library directory? + +When you build modules, use the PREFIX option when generating +Makefiles: + + perl Makefile.PL PREFIX=/u/mydir/perl + +then either set the PERL5LIB environment variable before you run +scripts that use the modules/libraries (see L<perlrun>) or say + + use lib '/u/mydir/perl'; + +See Perl's L<lib> for more information. + +=head2 How do I add the directory my program lives in to the module/library search path? + + use FindBin; + use lib "$FindBin:Bin"; + use your_own_modules; + +=head2 How do I add a directory to my include path at runtime? + +Here are the suggested ways of modifying your include path: + + the PERLLIB environment variable + the PERL5LIB environment variable + the perl -Idir commpand line flag + the use lib pragma, as in + use lib "$ENV{HOME}/myown_perllib"; + +The latter is particularly useful because it knows about machine +dependent architectures. The lib.pm pragmatic module was first +included with the 5.002 release of Perl. + +=head1 How do I get one key from the terminal at a time, under POSIX? + + #!/usr/bin/perl -w + use strict; + $| = 1; + for (1..4) { + my $got; + print "gimme: "; + $got = getone(); + print "--> $got\n"; + } + exit; + + BEGIN { + use POSIX qw(:termios_h); + + my ($term, $oterm, $echo, $noecho, $fd_stdin); + + $fd_stdin = fileno(STDIN); + + $term = POSIX::Termios->new(); + $term->getattr($fd_stdin); + $oterm = $term->getlflag(); + + $echo = ECHO | ECHOK | ICANON; + $noecho = $oterm & ~$echo; + + sub cbreak { + $term->setlflag($noecho); + $term->setcc(VTIME, 1); + $term->setattr($fd_stdin, TCSANOW); + } + + sub cooked { + $term->setlflag($oterm); + $term->setcc(VTIME, 0); + $term->setattr($fd_stdin, TCSANOW); + } + + sub getone { + my $key = ''; + cbreak(); + sysread(STDIN, $key, 1); + cooked(); + return $key; + } + + } + END { cooked() } + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. diff --git a/gnu/usr.bin/perl/pod/perlfaq9.pod b/gnu/usr.bin/perl/pod/perlfaq9.pod new file mode 100644 index 00000000000..aa942c2da05 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlfaq9.pod @@ -0,0 +1,331 @@ +=head1 NAME + +perlfaq9 - Networking ($Revision: 1.17 $, $Date: 1997/04/24 22:44:29 $) + +=head1 DESCRIPTION + +This section deals with questions related to networking, the internet, +and a few on the web. + +=head2 My CGI script runs from the command line but not the browser. Can you help me fix it? + +Sure, but you probably can't afford our contracting rates :-) + +Seriously, if you can demonstrate that you've read the following FAQs +and that your problem isn't something simple that can be easily +answered, you'll probably receive a courteous and useful reply to your +question if you post it on comp.infosystems.www.authoring.cgi (if it's +something to do with HTTP, HTML, or the CGI protocols). Questions that +appear to be Perl questions but are really CGI ones that are posted to +comp.lang.perl.misc may not be so well received. + +The useful FAQs are: + + http://www.perl.com/perl/faq/idiots-guide.html + http://www3.pair.com/webthing/docs/cgi/faqs/cgifaq.shtml + http://www.perl.com/perl/faq/perl-cgi-faq.html + http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html + http://www.boutell.com/faq/ + +=head2 How do I remove HTML from a string? + +The most correct way (albeit not the fastest) is to use HTML::Parse +from CPAN (part of the libwww-perl distribution, which is a must-have +module for all web hackers). + +Many folks attempt a simple-minded regular expression approach, like +C<s/E<lt>.*?E<gt>//g>, but that fails in many cases because the tags +may continue over line breaks, they may contain quoted angle-brackets, +or HTML comment may be present. Plus folks forget to convert +entities, like C<<> for example. + +Here's one "simple-minded" approach, that works for most files: + + #!/usr/bin/perl -p0777 + s/<(?:[^>'"]*|(['"]).*?\1)*>//gs + +If you want a more complete solution, see the 3-stage striphtml +program in +http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/striphtml.gz +. + +=head2 How do I extract URLs? + +A quick but imperfect approach is + + #!/usr/bin/perl -n00 + # qxurl - tchrist@perl.com + print "$2\n" while m{ + < \s* + A \s+ HREF \s* = \s* (["']) (.*?) \1 + \s* > + }gsix; + +This version does not adjust relative URLs, understand alternate +bases, deal with HTML comments, deal with HREF and NAME attributes in +the same tag, or accept URLs themselves as arguments. It also runs +about 100x faster than a more "complete" solution using the LWP suite +of modules, such as the +http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/xurl.gz +program. + +=head2 How do I download a file from the user's machine? How do I open a file on another machine? + +In the context of an HTML form, you can use what's known as +B<multipart/form-data> encoding. The CGI.pm module (available from +CPAN) supports this in the start_multipart_form() method, which isn't +the same as the startform() method. + +=head2 How do I make a pop-up menu in HTML? + +Use the B<E<lt>SELECTE<gt>> and B<E<lt>OPTIONE<gt>> tags. The CGI.pm +module (available from CPAN) supports this widget, as well as many +others, including some that it cleverly synthesizes on its own. + +=head2 How do I fetch an HTML file? + +One approach, if you have the lynx text-based HTML browser installed +on your system, is this: + + $html_code = `lynx -source $url`; + $text_data = `lynx -dump $url`; + +The libwww-perl (LWP) modules from CPAN provide a more powerful way to +do this. They work through proxies, and don't require lynx: + + # print HTML from a URL + use LWP::Simple; + getprint "http://www.sn.no/libwww-perl/"; + + # print ASCII from HTML from a URL + use LWP::Simple; + use HTML::Parse; + use HTML::FormatText; + my ($html, $ascii); + $html = get("http://www.perl.com/"); + defined $html + or die "Can't fetch HTML from http://www.perl.com/"; + $ascii = HTML::FormatText->new->format(parse_html($html)); + print $ascii; + +=head2 how do I decode or create those %-encodings on the web? + +Here's an example of decoding: + + $string = "http://altavista.digital.com/cgi-bin/query?pg=q&what=news&fmt=.&q=%2Bcgi-bin+%2Bperl.exe"; + $string =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge; + +Encoding is a bit harder, because you can't just blindly change +all the non-alphanumunder character (C<\W>) into their hex escapes. +It's important that characters with special meaning like C</> and C<?> +I<not> be translated. Probably the easiest way to get this right is +to avoid reinventing the wheel and just use the URI::Escape module, +which is part of the libwww-perl package (LWP) available from CPAN. + +=head2 How do I redirect to another page? + +Instead of sending back a C<Content-Type> as the headers of your +reply, send back a C<Location:> header. Officially this should be a +C<URI:> header, so the CGI.pm module (available from CPAN) sends back +both: + + Location: http://www.domain.com/newpage + URI: http://www.domain.com/newpage + +Note that relative URLs in these headers can cause strange effects +because of "optimizations" that servers do. + +=head2 How do I put a password on my web pages? + +That depends. You'll need to read the documentation for your web +server, or perhaps check some of the other FAQs referenced above. + +=head2 How do I edit my .htpasswd and .htgroup files with Perl? + +The HTTPD::UserAdmin and HTTPD::GroupAdmin modules provide a +consistent OO interface to these files, regardless of how they're +stored. Databases may be text, dbm, Berkley DB or any database with a +DBI compatible driver. HTTPD::UserAdmin supports files used by the +`Basic' and `Digest' authentication schemes. Here's an example: + + use HTTPD::UserAdmin (); + HTTPD::UserAdmin + ->new(DB => "/foo/.htpasswd") + ->add($username => $password); + +=head2 How do I make sure users can't enter values into a form that cause my CGI script to do bad things? + +Read the CGI security FAQ, at +http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html, and the +Perl/CGI FAQ at +http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html. + +In brief: use tainting (see L<perlsec>), which makes sure that data +from outside your script (eg, CGI parameters) are never used in +C<eval> or C<system> calls. In addition to tainting, never use the +single-argument form of system() or exec(). Instead, supply the +command and arguments as a list, which prevents shell globbing. + +=head2 How do I parse an email header? + +For a quick-and-dirty solution, try this solution derived +from page 222 of the 2nd edition of "Programming Perl": + + $/ = ''; + $header = <MSG>; + $header =~ s/\n\s+/ /g; # merge continuation lines + %head = ( UNIX_FROM_LINE, split /^([-\w]+):\s*/m, $header ); + +That solution doesn't do well if, for example, you're trying to +maintain all the Received lines. A more complete approach is to use +the Mail::Header module from CPAN (part of the MailTools package). + +=head2 How do I decode a CGI form? + +A lot of people are tempted to code this up themselves, so you've +probably all seen a lot of code involving C<$ENV{CONTENT_LENGTH}> and +C<$ENV{QUERY_STRING}>. It's true that this can work, but there are +also a lot of versions of this floating around that are quite simply +broken! + +Please do not be tempted to reinvent the wheel. Instead, use the +CGI.pm or CGI_Lite.pm (available from CPAN), or if you're trapped in +the module-free land of perl1 .. perl4, you might look into cgi-lib.pl +(available from http://www.bio.cam.ac.uk/web/form.html). + +=head2 How do I check a valid email address? + +You can't. + +Without sending mail to the address and seeing whether it bounces (and +even then you face the halting problem), you cannot determine whether +an email address is valid. Even if you apply the email header +standard, you can have problems, because there are deliverable +addresses that aren't RFC-822 (the mail header standard) compliant, +and addresses that aren't deliverable which are compliant. + +Many are tempted to try to eliminate many frequently-invalid email +addresses with a simple regexp, such as +C</^[\w.-]+\@([\w.-]\.)+\w+$/>. However, this also throws out many +valid ones, and says nothing about potential deliverability, so is not +suggested. Instead, see +http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/ckaddr.gz , +which actually checks against the full RFC spec (except for nested +comments), looks for addresses you may not wish to accept email to +(say, Bill Clinton or your postmaster), and then makes sure that the +hostname given can be looked up in DNS. It's not fast, but it works. + +Here's an alternative strategy used by many CGI script authors: Check +the email address with a simple regexp (such as the one above). If +the regexp matched the address, accept the address. If the regexp +didn't match the address, request confirmation from the user that the +email address they entered was correct. + +=head2 How do I decode a MIME/BASE64 string? + +The MIME-tools package (available from CPAN) handles this and a lot +more. Decoding BASE64 becomes as simple as: + + use MIME::base64; + $decoded = decode_base64($encoded); + +A more direct approach is to use the unpack() function's "u" +format after minor transliterations: + + tr#A-Za-z0-9+/##cd; # remove non-base64 chars + tr#A-Za-z0-9+/# -_#; # convert to uuencoded format + $len = pack("c", 32 + 0.75*length); # compute length byte + print unpack("u", $len . $_); # uudecode and print + +=head2 How do I return the user's email address? + +On systems that support getpwuid, the $E<lt> variable and the +Sys::Hostname module (which is part of the standard perl distribution), +you can probably try using something like this: + + use Sys::Hostname; + $address = sprintf('%s@%s', getpwuid($<), hostname); + +Company policies on email address can mean that this generates addresses +that the company's email system will not accept, so you should ask for +users' email addresses when this matters. Furthermore, not all systems +on which Perl runs are so forthcoming with this information as is Unix. + +The Mail::Util module from CPAN (part of the MailTools package) provides a +mailaddress() function that tries to guess the mail address of the user. +It makes a more intelligent guess than the code above, using information +given when the module was installed, but it could still be incorrect. +Again, the best way is often just to ask the user. + +=head2 How do I send/read mail? + +Sending mail: the Mail::Mailer module from CPAN (part of the MailTools +package) is UNIX-centric, while Mail::Internet uses Net::SMTP which is +not UNIX-centric. Reading mail: use the Mail::Folder module from CPAN +(part of the MailFolder package) or the Mail::Internet module from +CPAN (also part of the MailTools package). + + # sending mail + use Mail::Internet; + use Mail::Header; + # say which mail host to use + $ENV{SMTPHOSTS} = 'mail.frii.com'; + # create headers + $header = new Mail::Header; + $header->add('From', 'gnat@frii.com'); + $header->add('Subject', 'Testing'); + $header->add('To', 'gnat@frii.com'); + # create body + $body = 'This is a test, ignore'; + # create mail object + $mail = new Mail::Internet(undef, Header => $header, Body => \[$body]); + # send it + $mail->smtpsend or die; + +=head2 How do I find out my hostname/domainname/IP address? + +A lot of code has historically cavalierly called the C<`hostname`> +program. While sometimes expedient, this isn't very portable. It's +one of those tradeoffs of convenience versus portability. + +The Sys::Hostname module (part of the standard perl distribution) will +give you the hostname after which you can find out the IP address +(assuming you have working DNS) with a gethostbyname() call. + + use Socket; + use Sys::Hostname; + my $host = hostname(); + my $addr = inet_ntoa(scalar(gethostbyname($name)) || 'localhost'); + +Probably the simplest way to learn your DNS domain name is to grok +it out of /etc/resolv.conf, at least under Unix. Of course, this +assumes several things about your resolv.conf configuration, including +that it exists. + +(We still need a good DNS domain name-learning method for non-Unix +systems.) + +=head2 How do I fetch a news article or the active newsgroups? + +Use the Net::NNTP or News::NNTPClient modules, both available from CPAN. +This can make tasks like fetching the newsgroup list as simple as: + + perl -MNews::NNTPClient + -e 'print News::NNTPClient->new->list("newsgroups")' + +=head2 How do I fetch/put an FTP file? + +LWP::Simple (available from CPAN) can fetch but not put. Net::FTP (also +available from CPAN) is more complex but can put as well as fetch. + +=head2 How can I do RPC in Perl? + +A DCE::RPC module is being developed (but is not yet available), and +will be released as part of the DCE-Perl package (available from +CPAN). No ONC::RPC module is known. + +=head1 AUTHOR AND COPYRIGHT + +Copyright (c) 1997 Tom Christiansen and Nathan Torkington. +All rights reserved. See L<perlfaq> for distribution information. + diff --git a/gnu/usr.bin/perl/pod/perllocale.pod b/gnu/usr.bin/perl/pod/perllocale.pod new file mode 100644 index 00000000000..e1bf5f070df --- /dev/null +++ b/gnu/usr.bin/perl/pod/perllocale.pod @@ -0,0 +1,800 @@ +=head1 NAME + +perllocale - Perl locale handling (internationalization and localization) + +=head1 DESCRIPTION + +Perl supports language-specific notions of data such as "is this a +letter", "what is the uppercase equivalent of this letter", and "which +of these letters comes first". These are important issues, especially +for languages other than English - but also for English: it would be +very naE<iuml>ve to think that C<A-Za-z> defines all the "letters". Perl +is also aware that some character other than '.' may be preferred as a +decimal point, and that output date representations may be +language-specific. The process of making an application take account of +its users' preferences in such matters is called B<internationalization> +(often abbreviated as B<i18n>); telling such an application about a +particular set of preferences is known as B<localization> (B<l10n>). + +Perl can understand language-specific data via the standardized (ISO C, +XPG4, POSIX 1.c) method called "the locale system". The locale system is +controlled per application using one pragma, one function call, and +several environment variables. + +B<NOTE>: This feature is new in Perl 5.004, and does not apply unless an +application specifically requests it - see L<Backward compatibility>. +The one exception is that write() now B<always> uses the current locale +- see L<"NOTES">. + +=head1 PREPARING TO USE LOCALES + +If Perl applications are to be able to understand and present your data +correctly according a locale of your choice, B<all> of the following +must be true: + +=over 4 + +=item * + +B<Your operating system must support the locale system>. If it does, +you should find that the setlocale() function is a documented part of +its C library. + +=item * + +B<Definitions for the locales which you use must be installed>. You, or +your system administrator, must make sure that this is the case. The +available locales, the location in which they are kept, and the manner +in which they are installed, vary from system to system. Some systems +provide only a few, hard-wired, locales, and do not allow more to be +added; others allow you to add "canned" locales provided by the system +supplier; still others allow you or the system administrator to define +and add arbitrary locales. (You may have to ask your supplier to +provide canned locales which are not delivered with your operating +system.) Read your system documentation for further illumination. + +=item * + +B<Perl must believe that the locale system is supported>. If it does, +C<perl -V:d_setlocale> will say that the value for C<d_setlocale> is +C<define>. + +=back + +If you want a Perl application to process and present your data +according to a particular locale, the application code should include +the S<C<use locale>> pragma (see L<The use locale pragma>) where +appropriate, and B<at least one> of the following must be true: + +=over 4 + +=item * + +B<The locale-determining environment variables (see L<"ENVIRONMENT">) +must be correctly set up>, either by yourself, or by the person who set +up your system account, at the time the application is started. + +=item * + +B<The application must set its own locale> using the method described in +L<The setlocale function>. + +=back + +=head1 USING LOCALES + +=head2 The use locale pragma + +By default, Perl ignores the current locale. The S<C<use locale>> +pragma tells Perl to use the current locale for some operations: + +=over 4 + +=item * + +B<The comparison operators> (C<lt>, C<le>, C<cmp>, C<ge>, and C<gt>) and +the POSIX string collation functions strcoll() and strxfrm() use +C<LC_COLLATE>. sort() is also affected if it is used without an +explicit comparison function because it uses C<cmp> by default. + +B<Note:> C<eq> and C<ne> are unaffected by the locale: they always +perform a byte-by-byte comparison of their scalar operands. What's +more, if C<cmp> finds that its operands are equal according to the +collation sequence specified by the current locale, it goes on to +perform a byte-by-byte comparison, and only returns I<0> (equal) if the +operands are bit-for-bit identical. If you really want to know whether +two strings - which C<eq> and C<cmp> may consider different - are equal +as far as collation in the locale is concerned, see the discussion in +L<Category LC_COLLATE: Collation>. + +=item * + +B<Regular expressions and case-modification functions> (uc(), lc(), +ucfirst(), and lcfirst()) use C<LC_CTYPE> + +=item * + +B<The formatting functions> (printf(), sprintf() and write()) use +C<LC_NUMERIC> + +=item * + +B<The POSIX date formatting function> (strftime()) uses C<LC_TIME>. + +=back + +C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in L<LOCALE +CATEGORIES>. + +The default behavior returns with S<C<no locale>> or on reaching the +end of the enclosing block. + +Note that the string result of any operation that uses locale +information is tainted, as it is possible for a locale to be +untrustworthy. See L<"SECURITY">. + +=head2 The setlocale function + +You can switch locales as often as you wish at run time with the +POSIX::setlocale() function: + + # This functionality not usable prior to Perl 5.004 + require 5.004; + + # Import locale-handling tool set from POSIX module. + # This example uses: setlocale -- the function call + # LC_CTYPE -- explained below + use POSIX qw(locale_h); + + # query and save the old locale + $old_locale = setlocale(LC_CTYPE); + + setlocale(LC_CTYPE, "fr_CA.ISO8859-1"); + # LC_CTYPE now in locale "French, Canada, codeset ISO 8859-1" + + setlocale(LC_CTYPE, ""); + # LC_CTYPE now reset to default defined by LC_ALL/LC_CTYPE/LANG + # environment variables. See below for documentation. + + # restore the old locale + setlocale(LC_CTYPE, $old_locale); + +The first argument of setlocale() gives the B<category>, the second the +B<locale>. The category tells in what aspect of data processing you +want to apply locale-specific rules. Category names are discussed in +L<LOCALE CATEGORIES> and L<"ENVIRONMENT">. The locale is the name of a +collection of customization information corresponding to a particular +combination of language, country or territory, and codeset. Read on for +hints on the naming of locales: not all systems name locales as in the +example. + +If no second argument is provided, the function returns a string naming +the current locale for the category. You can use this value as the +second argument in a subsequent call to setlocale(). If a second +argument is given and it corresponds to a valid locale, the locale for +the category is set to that value, and the function returns the +now-current locale value. You can use this in a subsequent call to +setlocale(). (In some implementations, the return value may sometimes +differ from the value you gave as the second argument - think of it as +an alias for the value that you gave.) + +As the example shows, if the second argument is an empty string, the +category's locale is returned to the default specified by the +corresponding environment variables. Generally, this results in a +return to the default which was in force when Perl started up: changes +to the environment made by the application after startup may or may not +be noticed, depending on the implementation of your system's C library. + +If the second argument does not correspond to a valid locale, the locale +for the category is not changed, and the function returns I<undef>. + +For further information about the categories, consult L<setlocale(3)>. +For the locales available in your system, also consult L<setlocale(3)> +and see whether it leads you to the list of the available locales +(search for the I<SEE ALSO> section). If that fails, try the following +command lines: + + locale -a + + nlsinfo + + ls /usr/lib/nls/loc + + ls /usr/lib/locale + + ls /usr/lib/nls + +and see whether they list something resembling these + + en_US.ISO8859-1 de_DE.ISO8859-1 ru_RU.ISO8859-5 + en_US de_DE ru_RU + en de ru + english german russian + english.iso88591 german.iso88591 russian.iso88595 + +Sadly, even though the calling interface for setlocale() has been +standardized, the names of the locales and the directories where +the configuration is, have not. The basic form of the name is +I<language_country/territory>B<.>I<codeset>, but the +latter parts are not always present. + +Two special locales are worth particular mention: "C" and "POSIX". +Currently these are effectively the same locale: the difference is +mainly that the first one is defined by the C standard and the second by +the POSIX standard. What they define is the B<default locale> in which +every program starts in the absence of locale information in its +environment. (The default default locale, if you will.) Its language +is (American) English and its character codeset ASCII. + +B<NOTE>: Not all systems have the "POSIX" locale (not all systems are +POSIX-conformant), so use "C" when you need explicitly to specify this +default locale. + +=head2 The localeconv function + +The POSIX::localeconv() function allows you to get particulars of the +locale-dependent numeric formatting information specified by the current +C<LC_NUMERIC> and C<LC_MONETARY> locales. (If you just want the name of +the current locale for a particular category, use POSIX::setlocale() +with a single parameter - see L<The setlocale function>.) + + use POSIX qw(locale_h); + + # Get a reference to a hash of locale-dependent info + $locale_values = localeconv(); + + # Output sorted list of the values + for (sort keys %$locale_values) { + printf "%-20s = %s\n", $_, $locale_values->{$_} + } + +localeconv() takes no arguments, and returns B<a reference to> a hash. +The keys of this hash are formatting variable names such as +C<decimal_point> and C<thousands_sep>; the values are the corresponding +values. See L<POSIX (3)/localeconv> for a longer example, which lists +all the categories an implementation might be expected to provide; some +provide more and others fewer, however. Note that you don't need C<use +locale>: as a function with the job of querying the locale, localeconv() +always observes the current locale. + +Here's a simple-minded example program which rewrites its command line +parameters as integers formatted correctly in the current locale: + + # See comments in previous example + require 5.004; + use POSIX qw(locale_h); + + # Get some of locale's numeric formatting parameters + my ($thousands_sep, $grouping) = + @{localeconv()}{'thousands_sep', 'grouping'}; + + # Apply defaults if values are missing + $thousands_sep = ',' unless $thousands_sep; + $grouping = 3 unless $grouping; + + # Format command line params for current locale + for (@ARGV) { + $_ = int; # Chop non-integer part + 1 while + s/(\d)(\d{$grouping}($|$thousands_sep))/$1$thousands_sep$2/; + print "$_"; + } + print "\n"; + +=head1 LOCALE CATEGORIES + +The subsections which follow describe basic locale categories. As well +as these, there are some combination categories which allow the +manipulation of more than one basic category at a time. See +L<"ENVIRONMENT"> for a discussion of these. + +=head2 Category LC_COLLATE: Collation + +When in the scope of S<C<use locale>>, Perl looks to the C<LC_COLLATE> +environment variable to determine the application's notions on the +collation (ordering) of characters. ('b' follows 'a' in Latin +alphabets, but where do 'E<aacute>' and 'E<aring>' belong?) + +Here is a code snippet that will tell you what are the alphanumeric +characters in the current locale, in the locale order: + + use locale; + print +(sort grep /\w/, map { chr() } 0..255), "\n"; + +Compare this with the characters that you see and their order if you +state explicitly that the locale should be ignored: + + no locale; + print +(sort grep /\w/, map { chr() } 0..255), "\n"; + +This machine-native collation (which is what you get unless S<C<use +locale>> has appeared earlier in the same block) must be used for +sorting raw binary data, whereas the locale-dependent collation of the +first example is useful for natural text. + +As noted in L<USING LOCALES>, C<cmp> compares according to the current +collation locale when C<use locale> is in effect, but falls back to a +byte-by-byte comparison for strings which the locale says are equal. You +can use POSIX::strcoll() if you don't want this fall-back: + + use POSIX qw(strcoll); + $equal_in_locale = + !strcoll("space and case ignored", "SpaceAndCaseIgnored"); + +$equal_in_locale will be true if the collation locale specifies a +dictionary-like ordering which ignores space characters completely, and +which folds case. + +If you have a single string which you want to check for "equality in +locale" against several others, you might think you could gain a little +efficiency by using POSIX::strxfrm() in conjunction with C<eq>: + + use POSIX qw(strxfrm); + $xfrm_string = strxfrm("Mixed-case string"); + print "locale collation ignores spaces\n" + if $xfrm_string eq strxfrm("Mixed-casestring"); + print "locale collation ignores hyphens\n" + if $xfrm_string eq strxfrm("Mixedcase string"); + print "locale collation ignores case\n" + if $xfrm_string eq strxfrm("mixed-case string"); + +strxfrm() takes a string and maps it into a transformed string for use +in byte-by-byte comparisons against other transformed strings during +collation. "Under the hood", locale-affected Perl comparison operators +call strxfrm() for both their operands, then do a byte-by-byte +comparison of the transformed strings. By calling strxfrm() explicitly, +and using a non locale-affected comparison, the example attempts to save +a couple of transformations. In fact, it doesn't save anything: Perl +magic (see L<perlguts/Magic Variables>) creates the transformed version of a +string the first time it's needed in a comparison, then keeps it around +in case it's needed again. An example rewritten the easy way with +C<cmp> runs just about as fast. It also copes with null characters +embedded in strings; if you call strxfrm() directly, it treats the first +null it finds as a terminator. And don't expect the transformed strings +it produces to be portable across systems - or even from one revision +of your operating system to the next. In short, don't call strxfrm() +directly: let Perl do it for you. + +Note: C<use locale> isn't shown in some of these examples, as it isn't +needed: strcoll() and strxfrm() exist only to generate locale-dependent +results, and so always obey the current C<LC_COLLATE> locale. + +=head2 Category LC_CTYPE: Character Types + +When in the scope of S<C<use locale>>, Perl obeys the C<LC_CTYPE> locale +setting. This controls the application's notion of which characters are +alphabetic. This affects Perl's C<\w> regular expression metanotation, +which stands for alphanumeric characters - that is, alphabetic and +numeric characters. (Consult L<perlre> for more information about +regular expressions.) Thanks to C<LC_CTYPE>, depending on your locale +setting, characters like 'E<aelig>', 'E<eth>', 'E<szlig>', and +'E<oslash>' may be understood as C<\w> characters. + +The C<LC_CTYPE> locale also provides the map used in translating +characters between lower and uppercase. This affects the case-mapping +functions - lc(), lcfirst, uc() and ucfirst(); case-mapping +interpolation with C<\l>, C<\L>, C<\u> or <\U> in double-quoted strings +and in C<s///> substitutions; and case-independent regular expression +pattern matching using the C<i> modifier. + +Finally, C<LC_CTYPE> affects the POSIX character-class test functions - +isalpha(), islower() and so on. For example, if you move from the "C" +locale to a 7-bit Scandinavian one, you may find - possibly to your +surprise - that "|" moves from the ispunct() class to isalpha(). + +B<Note:> A broken or malicious C<LC_CTYPE> locale definition may result +in clearly ineligible characters being considered to be alphanumeric by +your application. For strict matching of (unaccented) letters and +digits - for example, in command strings - locale-aware applications +should use C<\w> inside a C<no locale> block. See L<"SECURITY">. + +=head2 Category LC_NUMERIC: Numeric Formatting + +When in the scope of S<C<use locale>>, Perl obeys the C<LC_NUMERIC> +locale information, which controls application's idea of how numbers +should be formatted for human readability by the printf(), sprintf(), +and write() functions. String to numeric conversion by the +POSIX::strtod() function is also affected. In most implementations the +only effect is to change the character used for the decimal point - +perhaps from '.' to ',': these functions aren't aware of such niceties +as thousands separation and so on. (See L<The localeconv function> if +you care about these things.) + +Note that output produced by print() is B<never> affected by the +current locale: it is independent of whether C<use locale> or C<no +locale> is in effect, and corresponds to what you'd get from printf() +in the "C" locale. The same is true for Perl's internal conversions +between numeric and string formats: + + use POSIX qw(strtod); + use locale; + + $n = 5/2; # Assign numeric 2.5 to $n + + $a = " $n"; # Locale-independent conversion to string + + print "half five is $n\n"; # Locale-independent output + + printf "half five is %g\n", $n; # Locale-dependent output + + print "DECIMAL POINT IS COMMA\n" + if $n == (strtod("2,5"))[0]; # Locale-dependent conversion + +=head2 Category LC_MONETARY: Formatting of monetary amounts + +The C standard defines the C<LC_MONETARY> category, but no function that +is affected by its contents. (Those with experience of standards +committees will recognize that the working group decided to punt on the +issue.) Consequently, Perl takes no notice of it. If you really want +to use C<LC_MONETARY>, you can query its contents - see L<The localeconv +function> - and use the information that it returns in your +application's own formatting of currency amounts. However, you may well +find that the information, though voluminous and complex, does not quite +meet your requirements: currency formatting is a hard nut to crack. + +=head2 LC_TIME + +The output produced by POSIX::strftime(), which builds a formatted +human-readable date/time string, is affected by the current C<LC_TIME> +locale. Thus, in a French locale, the output produced by the C<%B> +format element (full month name) for the first month of the year would +be "janvier". Here's how to get a list of the long month names in the +current locale: + + use POSIX qw(strftime); + for (0..11) { + $long_month_name[$_] = + strftime("%B", 0, 0, 0, 1, $_, 96); + } + +Note: C<use locale> isn't needed in this example: as a function which +exists only to generate locale-dependent results, strftime() always +obeys the current C<LC_TIME> locale. + +=head2 Other categories + +The remaining locale category, C<LC_MESSAGES> (possibly supplemented by +others in particular implementations) is not currently used by Perl - +except possibly to affect the behavior of library functions called by +extensions which are not part of the standard Perl distribution. + +=head1 SECURITY + +While the main discussion of Perl security issues can be found in +L<perlsec>, a discussion of Perl's locale handling would be incomplete +if it did not draw your attention to locale-dependent security issues. +Locales - particularly on systems which allow unprivileged users to +build their own locales - are untrustworthy. A malicious (or just plain +broken) locale can make a locale-aware application give unexpected +results. Here are a few possibilities: + +=over 4 + +=item * + +Regular expression checks for safe file names or mail addresses using +C<\w> may be spoofed by an C<LC_CTYPE> locale which claims that +characters such as "E<gt>" and "|" are alphanumeric. + +=item * + +String interpolation with case-mapping, as in, say, C<$dest = +"C:\U$name.$ext">, may produce dangerous results if a bogus LC_CTYPE +case-mapping table is in effect. + +=item * + +If the decimal point character in the C<LC_NUMERIC> locale is +surreptitiously changed from a dot to a comma, C<sprintf("%g", +0.123456e3)> produces a string result of "123,456". Many people would +interpret this as one hundred and twenty-three thousand, four hundred +and fifty-six. + +=item * + +A sneaky C<LC_COLLATE> locale could result in the names of students with +"D" grades appearing ahead of those with "A"s. + +=item * + +An application which takes the trouble to use the information in +C<LC_MONETARY> may format debits as if they were credits and vice versa +if that locale has been subverted. Or it make may make payments in US +dollars instead of Hong Kong dollars. + +=item * + +The date and day names in dates formatted by strftime() could be +manipulated to advantage by a malicious user able to subvert the +C<LC_DATE> locale. ("Look - it says I wasn't in the building on +Sunday.") + +=back + +Such dangers are not peculiar to the locale system: any aspect of an +application's environment which may maliciously be modified presents +similar challenges. Similarly, they are not specific to Perl: any +programming language which allows you to write programs which take +account of their environment exposes you to these issues. + +Perl cannot protect you from all of the possibilities shown in the +examples - there is no substitute for your own vigilance - but, when +C<use locale> is in effect, Perl uses the tainting mechanism (see +L<perlsec>) to mark string results which become locale-dependent, and +which may be untrustworthy in consequence. Here is a summary of the +tainting behavior of operators and functions which may be affected by +the locale: + +=over 4 + +=item B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>): + +Scalar true/false (or less/equal/greater) result is never tainted. + +=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or <\U>) + +Result string containing interpolated material is tainted if +C<use locale> is in effect. + +=item B<Matching operator> (C<m//>): + +Scalar true/false result never tainted. + +Subpatterns, either delivered as an array-context result, or as $1 etc. +are tainted if C<use locale> is in effect, and the subpattern regular +expression contains C<\w> (to match an alphanumeric character), C<\W> +(non-alphanumeric character), C<\s> (white-space character), or C<\S> +(non white-space character). The matched pattern variable, $&, $` +(pre-match), $' (post-match), and $+ (last match) are also tainted if +C<use locale> is in effect and the regular expression contains C<\w>, +C<\W>, C<\s>, or C<\S>. + +=item B<Substitution operator> (C<s///>): + +Has the same behavior as the match operator. Also, the left +operand of C<=~> becomes tainted when C<use locale> in effect, +if it is modified as a result of a substitution based on a regular +expression match involving C<\w>, C<\W>, C<\s>, or C<\S>; or of +case-mapping with C<\l>, C<\L>,C<\u> or <\U>. + +=item B<In-memory formatting function> (sprintf()): + +Result is tainted if "use locale" is in effect. + +=item B<Output formatting functions> (printf() and write()): + +Success/failure result is never tainted. + +=item B<Case-mapping functions> (lc(), lcfirst(), uc(), ucfirst()): + +Results are tainted if C<use locale> is in effect. + +=item B<POSIX locale-dependent functions> (localeconv(), strcoll(), +strftime(), strxfrm()): + +Results are never tainted. + +=item B<POSIX character class tests> (isalnum(), isalpha(), isdigit(), +isgraph(), islower(), isprint(), ispunct(), isspace(), isupper(), +isxdigit()): + +True/false results are never tainted. + +=back + +Three examples illustrate locale-dependent tainting. +The first program, which ignores its locale, won't run: a value taken +directly from the command line may not be used to name an output file +when taint checks are enabled. + + #/usr/local/bin/perl -T + # Run with taint checking + + # Command line sanity check omitted... + $tainted_output_file = shift; + + open(F, ">$tainted_output_file") + or warn "Open of $untainted_output_file failed: $!\n"; + +The program can be made to run by "laundering" the tainted value through +a regular expression: the second example - which still ignores locale +information - runs, creating the file named on its command line +if it can. + + #/usr/local/bin/perl -T + + $tainted_output_file = shift; + $tainted_output_file =~ m%[\w/]+%; + $untainted_output_file = $&; + + open(F, ">$untainted_output_file") + or warn "Open of $untainted_output_file failed: $!\n"; + +Compare this with a very similar program which is locale-aware: + + #/usr/local/bin/perl -T + + $tainted_output_file = shift; + use locale; + $tainted_output_file =~ m%[\w/]+%; + $localized_output_file = $&; + + open(F, ">$localized_output_file") + or warn "Open of $localized_output_file failed: $!\n"; + +This third program fails to run because $& is tainted: it is the result +of a match involving C<\w> when C<use locale> is in effect. + +=head1 ENVIRONMENT + +=over 12 + +=item PERL_BADLANG + +A string that can suppress Perl's warning about failed locale settings +at startup. Failure can occur if the locale support in the operating +system is lacking (broken) is some way - or if you mistyped the name of +a locale when you set up your environment. If this environment variable +is absent, or has a value which does not evaluate to integer zero - that +is "0" or "" - Perl will complain about locale setting failures. + +B<NOTE>: PERL_BADLANG only gives you a way to hide the warning message. +The message tells about some problem in your system's locale support, +and you should investigate what the problem is. + +=back + +The following environment variables are not specific to Perl: They are +part of the standardized (ISO C, XPG4, POSIX 1.c) setlocale() method +for controlling an application's opinion on data. + +=over 12 + +=item LC_ALL + +C<LC_ALL> is the "override-all" locale environment variable. If it is +set, it overrides all the rest of the locale environment variables. + +=item LC_CTYPE + +In the absence of C<LC_ALL>, C<LC_CTYPE> chooses the character type +locale. In the absence of both C<LC_ALL> and C<LC_CTYPE>, C<LANG> +chooses the character type locale. + +=item LC_COLLATE + +In the absence of C<LC_ALL>, C<LC_COLLATE> chooses the collation +(sorting) locale. In the absence of both C<LC_ALL> and C<LC_COLLATE>, +C<LANG> chooses the collation locale. + +=item LC_MONETARY + +In the absence of C<LC_ALL>, C<LC_MONETARY> chooses the monetary +formatting locale. In the absence of both C<LC_ALL> and C<LC_MONETARY>, +C<LANG> chooses the monetary formatting locale. + +=item LC_NUMERIC + +In the absence of C<LC_ALL>, C<LC_NUMERIC> chooses the numeric format +locale. In the absence of both C<LC_ALL> and C<LC_NUMERIC>, C<LANG> +chooses the numeric format. + +=item LC_TIME + +In the absence of C<LC_ALL>, C<LC_TIME> chooses the date and time +formatting locale. In the absence of both C<LC_ALL> and C<LC_TIME>, +C<LANG> chooses the date and time formatting locale. + +=item LANG + +C<LANG> is the "catch-all" locale environment variable. If it is set, it +is used as the last resort after the overall C<LC_ALL> and the +category-specific C<LC_...>. + +=back + +=head1 NOTES + +=head2 Backward compatibility + +Versions of Perl prior to 5.004 B<mostly> ignored locale information, +generally behaving as if something similar to the C<"C"> locale (see +L<The setlocale function>) was always in force, even if the program +environment suggested otherwise. By default, Perl still behaves this +way so as to maintain backward compatibility. If you want a Perl +application to pay attention to locale information, you B<must> use +the S<C<use locale>> pragma (see L<The use locale Pragma>) to +instruct it to do so. + +Versions of Perl from 5.002 to 5.003 did use the C<LC_CTYPE> +information if that was available, that is, C<\w> did understand what +are the letters according to the locale environment variables. +The problem was that the user had no control over the feature: +if the C library supported locales, Perl used them. + +=head2 I18N:Collate obsolete + +In versions of Perl prior to 5.004 per-locale collation was possible +using the C<I18N::Collate> library module. This module is now mildly +obsolete and should be avoided in new applications. The C<LC_COLLATE> +functionality is now integrated into the Perl core language: One can +use locale-specific scalar data completely normally with C<use locale>, +so there is no longer any need to juggle with the scalar references of +C<I18N::Collate>. + +=head2 Sort speed and memory use impacts + +Comparing and sorting by locale is usually slower than the default +sorting; slow-downs of two to four times have been observed. It will +also consume more memory: once a Perl scalar variable has participated +in any string comparison or sorting operation obeying the locale +collation rules, it will take 3-15 times more memory than before. (The +exact multiplier depends on the string's contents, the operating system +and the locale.) These downsides are dictated more by the operating +system's implementation of the locale system than by Perl. + +=head2 write() and LC_NUMERIC + +Formats are the only part of Perl which unconditionally use information +from a program's locale; if a program's environment specifies an +LC_NUMERIC locale, it is always used to specify the decimal point +character in formatted output. Formatted output cannot be controlled by +C<use locale> because the pragma is tied to the block structure of the +program, and, for historical reasons, formats exist outside that block +structure. + +=head2 Freely available locale definitions + +There is a large collection of locale definitions at +C<ftp://dkuug.dk/i18n/WG15-collection>. You should be aware that it is +unsupported, and is not claimed to be fit for any purpose. If your +system allows the installation of arbitrary locales, you may find the +definitions useful as they are, or as a basis for the development of +your own locales. + +=head2 I18n and l10n + +"Internationalization" is often abbreviated as B<i18n> because its first +and last letters are separated by eighteen others. (You may guess why +the internalin ... internaliti ... i18n tends to get abbreviated.) In +the same way, "localization" is often abbreviated to B<l10n>. + +=head2 An imperfect standard + +Internationalization, as defined in the C and POSIX standards, can be +criticized as incomplete, ungainly, and having too large a granularity. +(Locales apply to a whole process, when it would arguably be more useful +to have them apply to a single thread, window group, or whatever.) They +also have a tendency, like standards groups, to divide the world into +nations, when we all know that the world can equally well be divided +into bankers, bikers, gamers, and so on. But, for now, it's the only +standard we've got. This may be construed as a bug. + +=head1 BUGS + +=head2 Broken systems + +In certain system environments the operating system's locale support +is broken and cannot be fixed or used by Perl. Such deficiencies can +and will result in mysterious hangs and/or Perl core dumps when the +C<use locale> is in effect. When confronted with such a system, +please report in excruciating detail to <F<perlbug@perl.com>>, and +complain to your vendor: maybe some bug fixes exist for these problems +in your operating system. Sometimes such bug fixes are called an +operating system upgrade. + +=head1 SEE ALSO + +L<POSIX (3)/isalnum>, L<POSIX (3)/isalpha>, L<POSIX (3)/isdigit>, +L<POSIX (3)/isgraph>, L<POSIX (3)/islower>, L<POSIX (3)/isprint>, +L<POSIX (3)/ispunct>, L<POSIX (3)/isspace>, L<POSIX (3)/isupper>, +L<POSIX (3)/isxdigit>, L<POSIX (3)/localeconv>, L<POSIX (3)/setlocale>, +L<POSIX (3)/strcoll>, L<POSIX (3)/strftime>, L<POSIX (3)/strtod>, +L<POSIX (3)/strxfrm> + +=head1 HISTORY + +Jarkko Hietaniemi's original F<perli18n.pod> heavily hacked by Dominic +Dunlop, assisted by the perl5-porters. + +Last update: Wed Jan 22 11:04:58 EST 1997 diff --git a/gnu/usr.bin/perl/pod/perlmodlib.pod b/gnu/usr.bin/perl/pod/perlmodlib.pod new file mode 100644 index 00000000000..cfb281dcc7b --- /dev/null +++ b/gnu/usr.bin/perl/pod/perlmodlib.pod @@ -0,0 +1,1094 @@ +=head1 NAME + +perlmodlib - constructing new Perl modules and finding existing ones + +=head1 DESCRIPTION + +=head1 THE PERL MODULE LIBRARY + +A number of modules are included the Perl distribution. These are +described below, and all end in F<.pm>. You may also discover files in +the library directory that end in either F<.pl> or F<.ph>. These are old +libraries supplied so that old programs that use them still run. The +F<.pl> files will all eventually be converted into standard modules, and +the F<.ph> files made by B<h2ph> will probably end up as extension modules +made by B<h2xs>. (Some F<.ph> values may already be available through the +POSIX module.) The B<pl2pm> file in the distribution may help in your +conversion, but it's just a mechanical process and therefore far from +bulletproof. + +=head2 Pragmatic Modules + +They work somewhat like pragmas in that they tend to affect the compilation of +your program, and thus will usually work well only when used within a +C<use>, or C<no>. Most of these are locally scoped, so an inner BLOCK +may countermand any of these by saying: + + no integer; + no strict 'refs'; + +which lasts until the end of that BLOCK. + +Unlike the pragmas that effect the C<$^H> hints variable, the C<use +vars> and C<use subs> declarations are not BLOCK-scoped. They allow +you to predeclare a variables or subroutines within a particular +I<file> rather than just a block. Such declarations are effective +for the entire file for which they were declared. You cannot rescind +them with C<no vars> or C<no subs>. + +The following pragmas are defined (and have their own documentation). + +=over 12 + +=item use autouse MODULE => qw(sub1 sub2 sub3) + +Defers C<require MODULE> until someone calls one of the specified +subroutines (which must be exported by MODULE). This pragma should be +used with caution, and only when necessary. + +=item blib + +manipulate @INC at compile time to use MakeMaker's uninstalled version +of a package + +=item diagnostics + +force verbose warning diagnostics + +=item integer + +compute arithmetic in integer instead of double + +=item less + +request less of something from the compiler + +=item lib + +manipulate @INC at compile time + +=item locale + +use or ignore current locale for builtin operations (see L<perllocale>) + +=item ops + +restrict named opcodes when compiling or running Perl code + +=item overload + +overload basic Perl operations + +=item sigtrap + +enable simple signal handling + +=item strict + +restrict unsafe constructs + +=item subs + +predeclare sub names + +=item vmsish + +adopt certain VMS-specific behaviors + +=item vars + +predeclare global variable names + +=back + +=head2 Standard Modules + +Standard, bundled modules are all expected to behave in a well-defined +manner with respect to namespace pollution because they use the +Exporter module. See their own documentation for details. + +=over 12 + +=item AnyDBM_File + +provide framework for multiple DBMs + +=item AutoLoader + +load functions only on demand + +=item AutoSplit + +split a package for autoloading + +=item Benchmark + +benchmark running times of code + +=item CPAN + +interface to Comprehensive Perl Archive Network + +=item CPAN::FirstTime + +create a CPAN configuration file + +=item CPAN::Nox + +run CPAN while avoiding compiled extensions + +=item Carp + +warn of errors (from perspective of caller) + +=item Class::Struct + +declare struct-like datatypes + +=item Config + +access Perl configuration information + +=item Cwd + +get pathname of current working directory + +=item DB_File + +access to Berkeley DB + +=item Devel::SelfStubber + +generate stubs for a SelfLoading module + +=item DirHandle + +supply object methods for directory handles + +=item DynaLoader + +dynamically load C libraries into Perl code + +=item English + +use nice English (or awk) names for ugly punctuation variables + +=item Env + +import environment variables + +=item Exporter + +implements default import method for modules + +=item ExtUtils::Embed + +utilities for embedding Perl in C/C++ applications + +=item ExtUtils::Install + +install files from here to there + +=item ExtUtils::Liblist + +determine libraries to use and how to use them + +=item ExtUtils::MM_OS2 + +methods to override Unix behaviour in ExtUtils::MakeMaker + +=item ExtUtils::MM_Unix + +methods used by ExtUtils::MakeMaker + +=item ExtUtils::MM_VMS + +methods to override Unix behaviour in ExtUtils::MakeMaker + +=item ExtUtils::MakeMaker + +create an extension Makefile + +=item ExtUtils::Manifest + +utilities to write and check a MANIFEST file + +=item ExtUtils::Mkbootstrap + +make a bootstrap file for use by DynaLoader + +=item ExtUtils::Mksymlists + +write linker options files for dynamic extension + +=item ExtUtils::testlib + +add blib/* directories to @INC + +=item Fcntl + +load the C Fcntl.h defines + +=item File::Basename + +split a pathname into pieces + +=item File::CheckTree + +run many filetest checks on a tree + +=item File::Compare + +compare files or filehandles + +=item File::Copy + +copy files or filehandles + +=item File::Find + +traverse a file tree + +=item File::Path + +create or remove a series of directories + +=item File::stat + +by-name interface to Perl's builtin stat() functions + +=item FileCache + +keep more files open than the system permits + +=item FileHandle + +supply object methods for filehandles + +=item FindBin + +locate directory of original perl script + +=item GDBM_File + +access to the gdbm library + +=item Getopt::Long + +extended processing of command line options + +=item Getopt::Std + +process single-character switches with switch clustering + +=item I18N::Collate + +compare 8-bit scalar data according to the current locale + +=item IO + +load various IO modules + +=item IO::File + +supply object methods for filehandles + +=item IO::Handle + +supply object methods for I/O handles + +=item IO::Pipe + +supply object methods for pipes + +=item IO::Seekable + +supply seek based methods for I/O objects + +=item IO::Select + +OO interface to the select system call + +=item IO::Socket + +object interface to socket communications + +=item IPC::Open2 + +open a process for both reading and writing + +=item IPC::Open3 + +open a process for reading, writing, and error handling + +=item Math::BigFloat + +arbitrary length float math package + +=item Math::BigInt + +arbitrary size integer math package + +=item Math::Complex + +complex numbers and associated mathematical functions + +=item Math::Trig + +simple interface to parts of Math::Complex for those who +need trigonometric functions only for real numbers + +=item NDBM_File + +tied access to ndbm files + +=item Net::Ping + +Hello, anybody home? + +=item Net::hostent + +by-name interface to Perl's builtin gethost*() functions + +=item Net::netent + +by-name interface to Perl's builtin getnet*() functions + +=item Net::protoent + +by-name interface to Perl's builtin getproto*() functions + +=item Net::servent + +by-name interface to Perl's builtin getserv*() functions + +=item Opcode + +disable named opcodes when compiling or running perl code + +=item Pod::Text + +convert POD data to formatted ASCII text + +=item POSIX + +interface to IEEE Standard 1003.1 + +=item SDBM_File + +tied access to sdbm files + +=item Safe + +compile and execute code in restricted compartments + +=item Search::Dict + +search for key in dictionary file + +=item SelectSaver + +save and restore selected file handle + +=item SelfLoader + +load functions only on demand + +=item Shell + +run shell commands transparently within perl + +=item Socket + +load the C socket.h defines and structure manipulators + +=item Symbol + +manipulate Perl symbols and their names + +=item Sys::Hostname + +try every conceivable way to get hostname + +=item Sys::Syslog + +interface to the Unix syslog(3) calls + +=item Term::Cap + +termcap interface + +=item Term::Complete + +word completion module + +=item Term::ReadLine + +interface to various C<readline> packages + +=item Test::Harness + +run perl standard test scripts with statistics + +=item Text::Abbrev + +create an abbreviation table from a list + +=item Text::ParseWords + +parse text into an array of tokens + +=item Text::Soundex + +implementation of the Soundex Algorithm as described by Knuth + +=item Text::Tabs + +expand and unexpand tabs per the Unix expand(1) and unexpand(1) + +=item Text::Wrap + +line wrapping to form simple paragraphs + +=item Tie::Hash + +base class definitions for tied hashes + +=item Tie::RefHash + +base class definitions for tied hashes with references as keys + +=item Tie::Scalar + +base class definitions for tied scalars + +=item Tie::SubstrHash + +fixed-table-size, fixed-key-length hashing + +=item Time::Local + +efficiently compute time from local and GMT time + +=item Time::gmtime + +by-name interface to Perl's builtin gmtime() function + +=item Time::localtime + +by-name interface to Perl's builtin localtime() function + +=item Time::tm + +internal object used by Time::gmtime and Time::localtime + +=item UNIVERSAL + +base class for ALL classes (blessed references) + +=item User::grent + +by-name interface to Perl's builtin getgr*() functions + +=item User::pwent + +by-name interface to Perl's builtin getpw*() functions + +=back + +To find out I<all> the modules installed on your system, including +those without documentation or outside the standard release, do this: + + find `perl -e 'print "@INC"'` -name '*.pm' -print + +They should all have their own documentation installed and accessible via +your system man(1) command. If that fails, try the I<perldoc> program. + +=head2 Extension Modules + +Extension modules are written in C (or a mix of Perl and C) and may be +statically linked or in general are +dynamically loaded into Perl if and when you need them. Supported +extension modules include the Socket, Fcntl, and POSIX modules. + +Many popular C extension modules do not come bundled (at least, not +completely) due to their sizes, volatility, or simply lack of time for +adequate testing and configuration across the multitude of platforms on +which Perl was beta-tested. You are encouraged to look for them in +archie(1L), the Perl FAQ or Meta-FAQ, the WWW page, and even with their +authors before randomly posting asking for their present condition and +disposition. + +=head1 CPAN + +CPAN stands for the Comprehensive Perl Archive Network. This is a globally +replicated collection of all known Perl materials, including hundreds +of unbundled modules. Here are the major categories of modules: + +=over + +=item * +Language Extensions and Documentation Tools + +=item * +Development Support + +=item * +Operating System Interfaces + +=item * +Networking, Device Control (modems) and InterProcess Communication + +=item * +Data Types and Data Type Utilities + +=item * +Database Interfaces + +=item * +User Interfaces + +=item * +Interfaces to / Emulations of Other Programming Languages + +=item * +File Names, File Systems and File Locking (see also File Handles) + +=item * +String Processing, Language Text Processing, Parsing, and Searching + +=item * +Option, Argument, Parameter, and Configuration File Processing + +=item * +Internationalization and Locale + +=item * +Authentication, Security, and Encryption + +=item * +World Wide Web, HTML, HTTP, CGI, MIME + +=item * +Server and Daemon Utilities + +=item * +Archiving and Compression + +=item * +Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing + +=item * +Mail and Usenet News + +=item * +Control Flow Utilities (callbacks and exceptions etc) + +=item * +File Handle and Input/Output Stream Utilities + +=item * +Miscellaneous Modules + +=back + +The registered CPAN sites as of this writing include the following. +You should try to choose one close to you: + +=over + +=item * +Africa + + South Africa ftp://ftp.is.co.za/programming/perl/CPAN/ + +=item * +Asia + + Hong Kong ftp://ftp.hkstar.com/pub/CPAN/ + Japan ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/ + ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/ + South Korea ftp://ftp.nuri.net/pub/CPAN/ + Taiwan ftp://dongpo.math.ncu.edu.tw/perl/CPAN/ + ftp://ftp.wownet.net/pub2/PERL/ + +=item * +Australasia + + Australia ftp://ftp.netinfo.com.au/pub/perl/CPAN/ + New Zealand ftp://ftp.tekotago.ac.nz/pub/perl/CPAN/ + +=item * +Europe + + Austria ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/ + Belgium ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/ + Czech Republic ftp://sunsite.mff.cuni.cz/Languages/Perl/CPAN/ + Denmark ftp://sunsite.auc.dk/pub/languages/perl/CPAN/ + Finland ftp://ftp.funet.fi/pub/languages/perl/CPAN/ + France ftp://ftp.ibp.fr/pub/perl/CPAN/ + ftp://ftp.pasteur.fr/pub/computing/unix/perl/CPAN/ + Germany ftp://ftp.gmd.de/packages/CPAN/ + ftp://ftp.leo.org/pub/comp/programming/languages/perl/CPAN/ + ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/ + ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/ + ftp://ftp.uni-erlangen.de/pub/source/Perl/CPAN/ + ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/ + Greece ftp://ftp.ntua.gr/pub/lang/perl/ + Hungary ftp://ftp.kfki.hu/pub/packages/perl/CPAN/ + Italy ftp://cis.utovrm.it/CPAN/ + the Netherlands ftp://ftp.cs.ruu.nl/pub/PERL/CPAN/ + ftp://ftp.EU.net/packages/cpan/ + Norway ftp://ftp.uit.no/pub/languages/perl/cpan/ + Poland ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/ + ftp://sunsite.icm.edu.pl/pub/CPAN/ + Portugal ftp://ftp.ci.uminho.pt/pub/lang/perl/ + ftp://ftp.telepac.pt/pub/CPAN/ + Russia ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/ + Slovenia ftp://ftp.arnes.si/software/perl/CPAN/ + Spain ftp://ftp.etse.urv.es/pub/mirror/perl/ + ftp://ftp.rediris.es/mirror/CPAN/ + Sweden ftp://ftp.sunet.se/pub/lang/perl/CPAN/ + UK ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/ + ftp://sunsite.doc.ic.ac.uk/packages/CPAN/ + ftp://unix.hensa.ac.uk/mirrors/perl-CPAN/ + +=item * +North America + + Ontario ftp://ftp.utilis.com/public/CPAN/ + ftp://enterprise.ic.gc.ca/pub/perl/CPAN/ + Manitoba ftp://theory.uwinnipeg.ca/pub/CPAN/ + California ftp://ftp.digital.com/pub/plan/perl/CPAN/ + ftp://ftp.cdrom.com/pub/perl/CPAN/ + Colorado ftp://ftp.cs.colorado.edu/pub/perl/CPAN/ + Florida ftp://ftp.cis.ufl.edu/pub/perl/CPAN/ + Illinois ftp://uiarchive.uiuc.edu/pub/lang/perl/CPAN/ + Massachusetts ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/ + New York ftp://ftp.rge.com/pub/languages/perl/ + North Carolina ftp://ftp.duke.edu/pub/perl/ + Oklahoma ftp://ftp.ou.edu/mirrors/CPAN/ + Oregon http://www.perl.org/CPAN/ + ftp://ftp.orst.edu/pub/packages/CPAN/ + Pennsylvania ftp://ftp.epix.net/pub/languages/perl/ + Texas ftp://ftp.sedl.org/pub/mirrors/CPAN/ + ftp://ftp.metronet.com/pub/perl/ + +=item * +South America + + Chile ftp://sunsite.dcc.uchile.cl/pub/Lang/perl/CPAN/ + +=back + +For an up-to-date listing of CPAN sites, +see F<http://www.perl.com/perl/CPAN> or F<ftp://ftp.perl.com/perl/>. + +=head1 Modules: Creation, Use, and Abuse + +(The following section is borrowed directly from Tim Bunce's modules +file, available at your nearest CPAN site.) + +Perl implements a class using a package, but the presence of a +package doesn't imply the presence of a class. A package is just a +namespace. A class is a package that provides subroutines that can be +used as methods. A method is just a subroutine that expects, as its +first argument, either the name of a package (for "static" methods), +or a reference to something (for "virtual" methods). + +A module is a file that (by convention) provides a class of the same +name (sans the .pm), plus an import method in that class that can be +called to fetch exported symbols. This module may implement some of +its methods by loading dynamic C or C++ objects, but that should be +totally transparent to the user of the module. Likewise, the module +might set up an AUTOLOAD function to slurp in subroutine definitions on +demand, but this is also transparent. Only the F<.pm> file is required to +exist. See L<perlsub>, L<perltoot>, and L<AutoLoader> for details about +the AUTOLOAD mechanism. + +=head2 Guidelines for Module Creation + +=over 4 + +=item Do similar modules already exist in some form? + +If so, please try to reuse the existing modules either in whole or +by inheriting useful features into a new class. If this is not +practical try to get together with the module authors to work on +extending or enhancing the functionality of the existing modules. +A perfect example is the plethora of packages in perl4 for dealing +with command line options. + +If you are writing a module to expand an already existing set of +modules, please coordinate with the author of the package. It +helps if you follow the same naming scheme and module interaction +scheme as the original author. + +=item Try to design the new module to be easy to extend and reuse. + +Use blessed references. Use the two argument form of bless to bless +into the class name given as the first parameter of the constructor, +e.g.,: + + sub new { + my $class = shift; + return bless {}, $class; + } + +or even this if you'd like it to be used as either a static +or a virtual method. + + sub new { + my $self = shift; + my $class = ref($self) || $self; + return bless {}, $class; + } + +Pass arrays as references so more parameters can be added later +(it's also faster). Convert functions into methods where +appropriate. Split large methods into smaller more flexible ones. +Inherit methods from other modules if appropriate. + +Avoid class name tests like: C<die "Invalid" unless ref $ref eq 'FOO'>. +Generally you can delete the "C<eq 'FOO'>" part with no harm at all. +Let the objects look after themselves! Generally, avoid hard-wired +class names as far as possible. + +Avoid C<$r-E<gt>Class::func()> where using C<@ISA=qw(... Class ...)> and +C<$r-E<gt>func()> would work (see L<perlbot> for more details). + +Use autosplit so little used or newly added functions won't be a +burden to programs which don't use them. Add test functions to +the module after __END__ either using AutoSplit or by saying: + + eval join('',<main::DATA>) || die $@ unless caller(); + +Does your module pass the 'empty subclass' test? If you say +"C<@SUBCLASS::ISA = qw(YOURCLASS);>" your applications should be able +to use SUBCLASS in exactly the same way as YOURCLASS. For example, +does your application still work if you change: C<$obj = new YOURCLASS;> +into: C<$obj = new SUBCLASS;> ? + +Avoid keeping any state information in your packages. It makes it +difficult for multiple other packages to use yours. Keep state +information in objects. + +Always use B<-w>. Try to C<use strict;> (or C<use strict qw(...);>). +Remember that you can add C<no strict qw(...);> to individual blocks +of code which need less strictness. Always use B<-w>. Always use B<-w>! +Follow the guidelines in the perlstyle(1) manual. + +=item Some simple style guidelines + +The perlstyle manual supplied with perl has many helpful points. + +Coding style is a matter of personal taste. Many people evolve their +style over several years as they learn what helps them write and +maintain good code. Here's one set of assorted suggestions that +seem to be widely used by experienced developers: + +Use underscores to separate words. It is generally easier to read +$var_names_like_this than $VarNamesLikeThis, especially for +non-native speakers of English. It's also a simple rule that works +consistently with VAR_NAMES_LIKE_THIS. + +Package/Module names are an exception to this rule. Perl informally +reserves lowercase module names for 'pragma' modules like integer +and strict. Other modules normally begin with a capital letter and +use mixed case with no underscores (need to be short and portable). + +You may find it helpful to use letter case to indicate the scope +or nature of a variable. For example: + + $ALL_CAPS_HERE constants only (beware clashes with perl vars) + $Some_Caps_Here package-wide global/static + $no_caps_here function scope my() or local() variables + +Function and method names seem to work best as all lowercase. +e.g., C<$obj-E<gt>as_string()>. + +You can use a leading underscore to indicate that a variable or +function should not be used outside the package that defined it. + +=item Select what to export. + +Do NOT export method names! + +Do NOT export anything else by default without a good reason! + +Exports pollute the namespace of the module user. If you must +export try to use @EXPORT_OK in preference to @EXPORT and avoid +short or common names to reduce the risk of name clashes. + +Generally anything not exported is still accessible from outside the +module using the ModuleName::item_name (or C<$blessed_ref-E<gt>method>) +syntax. By convention you can use a leading underscore on names to +indicate informally that they are 'internal' and not for public use. + +(It is actually possible to get private functions by saying: +C<my $subref = sub { ... }; &$subref;>. But there's no way to call that +directly as a method, because a method must have a name in the symbol +table.) + +As a general rule, if the module is trying to be object oriented +then export nothing. If it's just a collection of functions then +@EXPORT_OK anything but use @EXPORT with caution. + +=item Select a name for the module. + +This name should be as descriptive, accurate, and complete as +possible. Avoid any risk of ambiguity. Always try to use two or +more whole words. Generally the name should reflect what is special +about what the module does rather than how it does it. Please use +nested module names to group informally or categorize a module. +There should be a very good reason for a module not to have a nested name. +Module names should begin with a capital letter. + +Having 57 modules all called Sort will not make life easy for anyone +(though having 23 called Sort::Quick is only marginally better :-). +Imagine someone trying to install your module alongside many others. +If in any doubt ask for suggestions in comp.lang.perl.misc. + +If you are developing a suite of related modules/classes it's good +practice to use nested classes with a common prefix as this will +avoid namespace clashes. For example: Xyz::Control, Xyz::View, +Xyz::Model etc. Use the modules in this list as a naming guide. + +If adding a new module to a set, follow the original author's +standards for naming modules and the interface to methods in +those modules. + +To be portable each component of a module name should be limited to +11 characters. If it might be used on MS-DOS then try to ensure each is +unique in the first 8 characters. Nested modules make this easier. + +=item Have you got it right? + +How do you know that you've made the right decisions? Have you +picked an interface design that will cause problems later? Have +you picked the most appropriate name? Do you have any questions? + +The best way to know for sure, and pick up many helpful suggestions, +is to ask someone who knows. Comp.lang.perl.misc is read by just about +all the people who develop modules and it's the best place to ask. + +All you need to do is post a short summary of the module, its +purpose and interfaces. A few lines on each of the main methods is +probably enough. (If you post the whole module it might be ignored +by busy people - generally the very people you want to read it!) + +Don't worry about posting if you can't say when the module will be +ready - just say so in the message. It might be worth inviting +others to help you, they may be able to complete it for you! + +=item README and other Additional Files. + +It's well known that software developers usually fully document the +software they write. If, however, the world is in urgent need of +your software and there is not enough time to write the full +documentation please at least provide a README file containing: + +=over 10 + +=item * +A description of the module/package/extension etc. + +=item * +A copyright notice - see below. + +=item * +Prerequisites - what else you may need to have. + +=item * +How to build it - possible changes to Makefile.PL etc. + +=item * +How to install it. + +=item * +Recent changes in this release, especially incompatibilities + +=item * +Changes / enhancements you plan to make in the future. + +=back + +If the README file seems to be getting too large you may wish to +split out some of the sections into separate files: INSTALL, +Copying, ToDo etc. + +=over 4 + +=item Adding a Copyright Notice. + +How you choose to license your work is a personal decision. +The general mechanism is to assert your Copyright and then make +a declaration of how others may copy/use/modify your work. + +Perl, for example, is supplied with two types of licence: The GNU +GPL and The Artistic Licence (see the files README, Copying, and +Artistic). Larry has good reasons for NOT just using the GNU GPL. + +My personal recommendation, out of respect for Larry, Perl, and the +perl community at large is to state something simply like: + + Copyright (c) 1995 Your Name. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + +This statement should at least appear in the README file. You may +also wish to include it in a Copying file and your source files. +Remember to include the other words in addition to the Copyright. + +=item Give the module a version/issue/release number. + +To be fully compatible with the Exporter and MakeMaker modules you +should store your module's version number in a non-my package +variable called $VERSION. This should be a floating point +number with at least two digits after the decimal (i.e., hundredths, +e.g, C<$VERSION = "0.01">). Don't use a "1.3.2" style version. +See Exporter.pm in Perl5.001m or later for details. + +It may be handy to add a function or method to retrieve the number. +Use the number in announcements and archive file names when +releasing the module (ModuleName-1.02.tar.Z). +See perldoc ExtUtils::MakeMaker.pm for details. + +=item How to release and distribute a module. + +It's good idea to post an announcement of the availability of your +module (or the module itself if small) to the comp.lang.perl.announce +Usenet newsgroup. This will at least ensure very wide once-off +distribution. + +If possible you should place the module into a major ftp archive and +include details of its location in your announcement. + +Some notes about ftp archives: Please use a long descriptive file +name which includes the version number. Most incoming directories +will not be readable/listable, i.e., you won't be able to see your +file after uploading it. Remember to send your email notification +message as soon as possible after uploading else your file may get +deleted automatically. Allow time for the file to be processed +and/or check the file has been processed before announcing its +location. + +FTP Archives for Perl Modules: + +Follow the instructions and links on + + http://franz.ww.tu-berlin.de/modulelist + +or upload to one of these sites: + + ftp://franz.ww.tu-berlin.de/incoming + ftp://ftp.cis.ufl.edu/incoming + +and notify <F<upload@franz.ww.tu-berlin.de>>. + +By using the WWW interface you can ask the Upload Server to mirror +your modules from your ftp or WWW site into your own directory on +CPAN! + +Please remember to send me an updated entry for the Module list! + +=item Take care when changing a released module. + +Always strive to remain compatible with previous released versions +(see 2.2 above) Otherwise try to add a mechanism to revert to the +old behaviour if people rely on it. Document incompatible changes. + +=back + +=back + +=head2 Guidelines for Converting Perl 4 Library Scripts into Modules + +=over 4 + +=item There is no requirement to convert anything. + +If it ain't broke, don't fix it! Perl 4 library scripts should +continue to work with no problems. You may need to make some minor +changes (like escaping non-array @'s in double quoted strings) but +there is no need to convert a .pl file into a Module for just that. + +=item Consider the implications. + +All the perl applications which make use of the script will need to +be changed (slightly) if the script is converted into a module. Is +it worth it unless you plan to make other changes at the same time? + +=item Make the most of the opportunity. + +If you are going to convert the script to a module you can use the +opportunity to redesign the interface. The 'Guidelines for Module +Creation' above include many of the issues you should consider. + +=item The pl2pm utility will get you started. + +This utility will read *.pl files (given as parameters) and write +corresponding *.pm files. The pl2pm utilities does the following: + +=over 10 + +=item * +Adds the standard Module prologue lines + +=item * +Converts package specifiers from ' to :: + +=item * +Converts die(...) to croak(...) + +=item * +Several other minor changes + +=back + +Being a mechanical process pl2pm is not bullet proof. The converted +code will need careful checking, especially any package statements. +Don't delete the original .pl file till the new .pm one works! + +=back + +=head2 Guidelines for Reusing Application Code + +=over 4 + +=item Complete applications rarely belong in the Perl Module Library. + +=item Many applications contain some perl code which could be reused. + +Help save the world! Share your code in a form that makes it easy +to reuse. + +=item Break-out the reusable code into one or more separate module files. + +=item Take the opportunity to reconsider and redesign the interfaces. + +=item In some cases the 'application' can then be reduced to a small + +fragment of code built on top of the reusable modules. In these cases +the application could invoked as: + + perl -e 'use Module::Name; method(@ARGV)' ... +or + perl -mModule::Name ... (in perl5.002 or higher) + +=back + +=head1 NOTE + +Perl does not enforce private and public parts of its modules as you may +have been used to in other languages like C++, Ada, or Modula-17. Perl +doesn't have an infatuation with enforced privacy. It would prefer +that you stayed out of its living room because you weren't invited, not +because it has a shotgun. + +The module and its user have a contract, part of which is common law, +and part of which is "written". Part of the common law contract is +that a module doesn't pollute any namespace it wasn't asked to. The +written contract for the module (A.K.A. documentation) may make other +provisions. But then you know when you C<use RedefineTheWorld> that +you're redefining the world and willing to take the consequences. diff --git a/gnu/usr.bin/perl/pod/perltoot.pod b/gnu/usr.bin/perl/pod/perltoot.pod new file mode 100644 index 00000000000..3a35c05b903 --- /dev/null +++ b/gnu/usr.bin/perl/pod/perltoot.pod @@ -0,0 +1,1789 @@ +=head1 NAME + +perltoot - Tom's object-oriented tutorial for perl + +=head1 DESCRIPTION + +Object-oriented programming is a big seller these days. Some managers +would rather have objects than sliced bread. Why is that? What's so +special about an object? Just what I<is> an object anyway? + +An object is nothing but a way of tucking away complex behaviours into +a neat little easy-to-use bundle. (This is what professors call +abstraction.) Smart people who have nothing to do but sit around for +weeks on end figuring out really hard problems make these nifty +objects that even regular people can use. (This is what professors call +software reuse.) Users (well, programmers) can play with this little +bundle all they want, but they aren't to open it up and mess with the +insides. Just like an expensive piece of hardware, the contract says +that you void the warranty if you muck with the cover. So don't do that. + +The heart of objects is the class, a protected little private namespace +full of data and functions. A class is a set of related routines that +addresses some problem area. You can think of it as a user-defined type. +The Perl package mechanism, also used for more traditional modules, +is used for class modules as well. Objects "live" in a class, meaning +that they belong to some package. + +More often than not, the class provides the user with little bundles. +These bundles are objects. They know whose class they belong to, +and how to behave. Users ask the class to do something, like "give +me an object." Or they can ask one of these objects to do something. +Asking a class to do something for you is calling a I<class method>. +Asking an object to do something for you is calling an I<object method>. +Asking either a class (usually) or an object (sometimes) to give you +back an object is calling a I<constructor>, which is just a +kind of method. + +That's all well and good, but how is an object different from any other +Perl data type? Just what is an object I<really>; that is, what's its +fundamental type? The answer to the first question is easy. An object +is different from any other data type in Perl in one and only one way: +you may dereference it using not merely string or numeric subscripts +as with simple arrays and hashes, but with named subroutine calls. +In a word, with I<methods>. + +The answer to the second question is that it's a reference, and not just +any reference, mind you, but one whose referent has been I<bless>()ed +into a particular class (read: package). What kind of reference? Well, +the answer to that one is a bit less concrete. That's because in Perl +the designer of the class can employ any sort of reference they'd like +as the underlying intrinsic data type. It could be a scalar, an array, +or a hash reference. It could even be a code reference. But because +of its inherent flexibility, an object is usually a hash reference. + +=head1 Creating a Class + +Before you create a class, you need to decide what to name it. That's +because the class (package) name governs the name of the file used to +house it, just as with regular modules. Then, that class (package) +should provide one or more ways to generate objects. Finally, it should +provide mechanisms to allow users of its objects to indirectly manipulate +these objects from a distance. + +For example, let's make a simple Person class module. It gets stored in +the file Person.pm. If it were called a Happy::Person class, it would +be stored in the file Happy/Person.pm, and its package would become +Happy::Person instead of just Person. (On a personal computer not +running Unix or Plan 9, but something like MacOS or VMS, the directory +separator may be different, but the principle is the same.) Do not assume +any formal relationship between modules based on their directory names. +This is merely a grouping convenience, and has no effect on inheritance, +variable accessibility, or anything else. + +For this module we aren't going to use Exporter, because we're +a well-behaved class module that doesn't export anything at all. +In order to manufacture objects, a class needs to have a I<constructor +method>. A constructor gives you back not just a regular data type, +but a brand-new object in that class. This magic is taken care of by +the bless() function, whose sole purpose is to enable its referent to +be used as an object. Remember: being an object really means nothing +more than that methods may now be called against it. + +While a constructor may be named anything you'd like, most Perl +programmers seem to like to call theirs new(). However, new() is not +a reserved word, and a class is under no obligation to supply such. +Some programmers have also been known to use a function with +the same name as the class as the constructor. + +=head2 Object Representation + +By far the most common mechanism used in Perl to represent a Pascal +record, a C struct, or a C++ class is an anonymous hash. That's because a +hash has an arbitrary number of data fields, each conveniently accessed by +an arbitrary name of your own devising. + +If you were just doing a simple +struct-like emulation, you would likely go about it something like this: + + $rec = { + name => "Jason", + age => 23, + peers => [ "Norbert", "Rhys", "Phineas"], + }; + +If you felt like it, you could add a bit of visual distinction +by up-casing the hash keys: + + $rec = { + NAME => "Jason", + AGE => 23, + PEERS => [ "Norbert", "Rhys", "Phineas"], + }; + +And so you could get at C<$rec-E<gt>{NAME}> to find "Jason", or +C<@{ $rec-E<gt>{PEERS} }> to get at "Norbert", "Rhys", and "Phineas". +(Have you ever noticed how many 23-year-old programmers seem to +be named "Jason" these days? :-) + +This same model is often used for classes, although it is not considered +the pinnacle of programming propriety for folks from outside the +class to come waltzing into an object, brazenly accessing its data +members directly. Generally speaking, an object should be considered +an opaque cookie that you use I<object methods> to access. Visually, +methods look like you're dereffing a reference using a function name +instead of brackets or braces. + +=head2 Class Interface + +Some languages provide a formal syntactic interface to a class's methods, +but Perl does not. It relies on you to read the documentation of each +class. If you try to call an undefined method on an object, Perl won't +complain, but the program will trigger an exception while it's running. +Likewise, if you call a method expecting a prime number as its argument +with a non-prime one instead, you can't expect the compiler to catch this. +(Well, you can expect it all you like, but it's not going to happen.) + +Let's suppose you have a well-educated user of your Person class, +someone who has read the docs that explain the prescribed +interface. Here's how they might use the Person class: + + use Person; + + $him = Person->new(); + $him->name("Jason"); + $him->age(23); + $him->peers( "Norbert", "Rhys", "Phineas" ); + + push @All_Recs, $him; # save object in array for later + + printf "%s is %d years old.\n", $him->name, $him->age; + print "His peers are: ", join(", ", $him->peers), "\n"; + + printf "Last rec's name is %s\n", $All_Recs[-1]->name; + +As you can see, the user of the class doesn't know (or at least, has no +business paying attention to the fact) that the object has one particular +implementation or another. The interface to the class and its objects +is exclusively via methods, and that's all the user of the class should +ever play with. + +=head2 Constructors and Instance Methods + +Still, I<someone> has to know what's in the object. And that someone is +the class. It implements methods that the programmer uses to access +the object. Here's how to implement the Person class using the standard +hash-ref-as-an-object idiom. We'll make a class method called new() to +act as the constructor, and three object methods called name(), age(), and +peers() to get at per-object data hidden away in our anonymous hash. + + package Person; + use strict; + + ################################################## + ## the object constructor (simplistic version) ## + ################################################## + sub new { + my $self = {}; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + bless($self); # but see below + return $self; + } + + ############################################## + ## methods to access per-object data ## + ## ## + ## With args, they set the value. Without ## + ## any, they only retrieve it/them. ## + ############################################## + + sub name { + my $self = shift; + if (@_) { $self->{NAME} = shift } + return $self->{NAME}; + } + + sub age { + my $self = shift; + if (@_) { $self->{AGE} = shift } + return $self->{AGE}; + } + + sub peers { + my $self = shift; + if (@_) { @{ $self->{PEERS} } = @_ } + return @{ $self->{PEERS} }; + } + + 1; # so the require or use succeeds + +We've created three methods to access an object's data, name(), age(), +and peers(). These are all substantially similar. If called with an +argument, they set the appropriate field; otherwise they return the +value held by that field, meaning the value of that hash key. + +=head2 Planning for the Future: Better Constructors + +Even though at this point you may not even know what it means, someday +you're going to worry about inheritance. (You can safely ignore this +for now and worry about it later if you'd like.) To ensure that this +all works out smoothly, you must use the double-argument form of bless(). +The second argument is the class into which the referent will be blessed. +By not assuming our own class as the default second argument and instead +using the class passed into us, we make our constructor inheritable. + +While we're at it, let's make our constructor a bit more flexible. +Rather than being uniquely a class method, we'll set it up so that +it can be called as either a class method I<or> an object +method. That way you can say: + + $me = Person->new(); + $him = $me->new(); + +To do this, all we have to do is check whether what was passed in +was a reference or not. If so, we were invoked as an object method, +and we need to extract the package (class) using the ref() function. +If not, we just use the string passed in as the package name +for blessing our referent. + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + bless ($self, $class); + return $self; + } + +That's about all there is for constructors. These methods bring objects +to life, returning neat little opaque bundles to the user to be used in +subsequent method calls. + +=head2 Destructors + +Every story has a beginning and an end. The beginning of the object's +story is its constructor, explicitly called when the object comes into +existence. But the ending of its story is the I<destructor>, a method +implicitly called when an object leaves this life. Any per-object +clean-up code is placed in the destructor, which must (in Perl) be called +DESTROY. + +If constructors can have arbitrary names, then why not destructors? +Because while a constructor is explicitly called, a destructor is not. +Destruction happens automatically via Perl's garbage collection (GC) +system, which is a quick but somewhat lazy reference-based GC system. +To know what to call, Perl insists that the destructor be named DESTROY. +Perl's notion of the right time to call a destructor is not well-defined +currently, which is why your destructors should not rely on when they are +called. + +Why is DESTROY in all caps? Perl on occasion uses purely uppercase +function names as a convention to indicate that the function will +be automatically called by Perl in some way. Others that are called +implicitly include BEGIN, END, AUTOLOAD, plus all methods used by +tied objects, described in L<perltie>. + +In really good object-oriented programming languages, the user doesn't +care when the destructor is called. It just happens when it's supposed +to. In low-level languages without any GC at all, there's no way to +depend on this happening at the right time, so the programmer must +explicitly call the destructor to clean up memory and state, crossing +their fingers that it's the right time to do so. Unlike C++, an +object destructor is nearly never needed in Perl, and even when it is, +explicit invocation is uncalled for. In the case of our Person class, +we don't need a destructor because Perl takes care of simple matters +like memory deallocation. + +The only situation where Perl's reference-based GC won't work is +when there's a circularity in the data structure, such as: + + $this->{WHATEVER} = $this; + +In that case, you must delete the self-reference manually if you expect +your program not to leak memory. While admittedly error-prone, this is +the best we can do right now. Nonetheless, rest assured that when your +program is finished, its objects' destructors are all duly called. +So you are guaranteed that an object I<eventually> gets properly +destroyed, except in the unique case of a program that never exits. +(If you're running Perl embedded in another application, this full GC +pass happens a bit more frequently--whenever a thread shuts down.) + +=head2 Other Object Methods + +The methods we've talked about so far have either been constructors or +else simple "data methods", interfaces to data stored in the object. +These are a bit like an object's data members in the C++ world, except +that strangers don't access them as data. Instead, they should only +access the object's data indirectly via its methods. This is an +important rule: in Perl, access to an object's data should I<only> +be made through methods. + +Perl doesn't impose restrictions on who gets to use which methods. +The public-versus-private distinction is by convention, not syntax. +(Well, unless you use the Alias module described below in +L</"Data Members as Variables">.) Occasionally you'll see method names beginning or ending +with an underscore or two. This marking is a convention indicating +that the methods are private to that class alone and sometimes to its +closest acquaintances, its immediate subclasses. But this distinction +is not enforced by Perl itself. It's up to the programmer to behave. + +There's no reason to limit methods to those that simply access data. +Methods can do anything at all. The key point is that they're invoked +against an object or a class. Let's say we'd like object methods that +do more than fetch or set one particular field. + + sub exclaim { + my $self = shift; + return sprintf "Hi, I'm %s, age %d, working with %s", + $self->{NAME}, $self->{AGE}, join(", ", $self->{PEERS}); + } + +Or maybe even one like this: + + sub happy_birthday { + my $self = shift; + return ++$self->{AGE}; + } + +Some might argue that one should go at these this way: + + sub exclaim { + my $self = shift; + return sprintf "Hi, I'm %s, age %d, working with %s", + $self->name, $self->age, join(", ", $self->peers); + } + + sub happy_birthday { + my $self = shift; + return $self->age( $self->age() + 1 ); + } + +But since these methods are all executing in the class itself, this +may not be critical. There are tradeoffs to be made. Using direct +hash access is faster (about an order of magnitude faster, in fact), and +it's more convenient when you want to interpolate in strings. But using +methods (the external interface) internally shields not just the users of +your class but even you yourself from changes in your data representation. + +=head1 Class Data + +What about "class data", data items common to each object in a class? +What would you want that for? Well, in your Person class, you might +like to keep track of the total people alive. How do you implement that? + +You I<could> make it a global variable called $Person::Census. But about +only reason you'd do that would be if you I<wanted> people to be able to +get at your class data directly. They could just say $Person::Census +and play around with it. Maybe this is ok in your design scheme. +You might even conceivably want to make it an exported variable. To be +exportable, a variable must be a (package) global. If this were a +traditional module rather than an object-oriented one, you might do that. + +While this approach is expected in most traditional modules, it's +generally considered rather poor form in most object modules. In an +object module, you should set up a protective veil to separate interface +from implementation. So provide a class method to access class data +just as you provide object methods to access object data. + +So, you I<could> still keep $Census as a package global and rely upon +others to honor the contract of the module and therefore not play around +with its implementation. You could even be supertricky and make $Census a +tied object as described in L<perltie>, thereby intercepting all accesses. + +But more often than not, you just want to make your class data a +file-scoped lexical. To do so, simply put this at the top of the file: + + my $Census = 0; + +Even though the scope of a my() normally expires when the block in which +it was declared is done (in this case the whole file being required or +used), Perl's deep binding of lexical variables guarantees that the +variable will not be deallocated, remaining accessible to functions +declared within that scope. This doesn't work with global variables +given temporary values via local(), though. + +Irrespective of whether you leave $Census a package global or make +it instead a file-scoped lexical, you should make these +changes to your Person::new() constructor: + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $Census++; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + bless ($self, $class); + return $self; + } + + sub population { + return $Census; + } + +Now that we've done this, we certainly do need a destructor so that +when Person is destroyed, the $Census goes down. Here's how +this could be done: + + sub DESTROY { --$Census } + +Notice how there's no memory to deallocate in the destructor? That's +something that Perl takes care of for you all by itself. + +=head2 Accessing Class Data + +It turns out that this is not really a good way to go about handling +class data. A good scalable rule is that I<you must never reference class +data directly from an object method>. Otherwise you aren't building a +scalable, inheritable class. The object must be the rendezvous point +for all operations, especially from an object method. The globals +(class data) would in some sense be in the "wrong" package in your +derived classes. In Perl, methods execute in the context of the class +they were defined in, I<not> that of the object that triggered them. +Therefore, namespace visibility of package globals in methods is unrelated +to inheritance. + +Got that? Maybe not. Ok, let's say that some other class "borrowed" +(well, inherited) the DESTROY method as it was defined above. When those +objects are destroyed, the original $Census variable will be altered, +not the one in the new class's package namespace. Perhaps this is what +you want, but probably it isn't. + +Here's how to fix this. We'll store a reference to the data in the +value accessed by the hash key "_CENSUS". Why the underscore? Well, +mostly because an initial underscore already conveys strong feelings +of magicalness to a C programmer. It's really just a mnemonic device +to remind ourselves that this field is special and not to be used as +a public data member in the same way that NAME, AGE, and PEERS are. +(Because we've been developing this code under the strict pragma, prior +to perl version 5.004 we'll have to quote the field name.) + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{NAME} = undef; + $self->{AGE} = undef; + $self->{PEERS} = []; + # "private" data + $self->{"_CENSUS"} = \$Census; + bless ($self, $class); + ++ ${ $self->{"_CENSUS"} }; + return $self; + } + + sub population { + my $self = shift; + if (ref $self) { + return ${ $self->{"_CENSUS"} }; + } else { + return $Census; + } + } + + sub DESTROY { + my $self = shift; + -- ${ $self->{"_CENSUS"} }; + } + +=head2 Debugging Methods + +It's common for a class to have a debugging mechanism. For example, +you might want to see when objects are created or destroyed. To do that, +add a debugging variable as a file-scoped lexical. For this, we'll pull +in the standard Carp module to emit our warnings and fatal messages. +That way messages will come out with the caller's filename and +line number instead of our own; if we wanted them to be from our own +perspective, we'd just use die() and warn() directly instead of croak() +and carp() respectively. + + use Carp; + my $Debugging = 0; + +Now add a new class method to access the variable. + + sub debug { + my $class = shift; + if (ref $class) { confess "Class method called as object method" } + unless (@_ == 1) { confess "usage: CLASSNAME->debug(level)" } + $Debugging = shift; + } + +Now fix up DESTROY to murmur a bit as the moribund object expires: + + sub DESTROY { + my $self = shift; + if ($Debugging) { carp "Destroying $self " . $self->name } + -- ${ $self->{"_CENSUS"} }; + } + +One could conceivably make a per-object debug state. That +way you could call both of these: + + Person->debug(1); # entire class + $him->debug(1); # just this object + +To do so, we need our debugging method to be a "bimodal" one, one that +works on both classes I<and> objects. Therefore, adjust the debug() +and DESTROY methods as follows: + + sub debug { + my $self = shift; + confess "usage: thing->debug(level)" unless @_ == 1; + my $level = shift; + if (ref($self)) { + $self->{"_DEBUG"} = $level; # just myself + } else { + $Debugging = $level; # whole class + } + } + + sub DESTROY { + my $self = shift; + if ($Debugging || $self->{"_DEBUG"}) { + carp "Destroying $self " . $self->name; + } + -- ${ $self->{"_CENSUS"} }; + } + +What happens if a derived class (which we'll call Employee) inherits +methods from this Person base class? Then C<Employee-E<gt>debug()>, when called +as a class method, manipulates $Person::Debugging not $Employee::Debugging. + +=head2 Class Destructors + +The object destructor handles the death of each distinct object. But sometimes +you want a bit of cleanup when the entire class is shut down, which +currently only happens when the program exits. To make such a +I<class destructor>, create a function in that class's package named +END. This works just like the END function in traditional modules, +meaning that it gets called whenever your program exits unless it execs +or dies of an uncaught signal. For example, + + sub END { + if ($Debugging) { + print "All persons are going away now.\n"; + } + } + +When the program exits, all the class destructors (END functions) are +be called in the opposite order that they were loaded in (LIFO order). + +=head2 Documenting the Interface + +And there you have it: we've just shown you the I<implementation> of this +Person class. Its I<interface> would be its documentation. Usually this +means putting it in pod ("plain old documentation") format right there +in the same file. In our Person example, we would place the following +docs anywhere in the Person.pm file. Even though it looks mostly like +code, it's not. It's embedded documentation such as would be used by +the pod2man, pod2html, or pod2text programs. The Perl compiler ignores +pods entirely, just as the translators ignore code. Here's an example of +some pods describing the informal interface: + + =head1 NAME + + Person - class to implement people + + =head1 SYNOPSIS + + use Person; + + ################# + # class methods # + ################# + $ob = Person->new; + $count = Person->population; + + ####################### + # object data methods # + ####################### + + ### get versions ### + $who = $ob->name; + $years = $ob->age; + @pals = $ob->peers; + + ### set versions ### + $ob->name("Jason"); + $ob->age(23); + $ob->peers( "Norbert", "Rhys", "Phineas" ); + + ######################## + # other object methods # + ######################## + + $phrase = $ob->exclaim; + $ob->happy_birthday; + + =head1 DESCRIPTION + + The Person class implements dah dee dah dee dah.... + +That's all there is to the matter of interface versus implementation. +A programmer who opens up the module and plays around with all the private +little shiny bits that were safely locked up behind the interface contract +has voided the warranty, and you shouldn't worry about their fate. + +=head1 Aggregation + +Suppose you later want to change the class to implement better names. +Perhaps you'd like to support both given names (called Christian names, +irrespective of one's religion) and family names (called surnames), plus +nicknames and titles. If users of your Person class have been properly +accessing it through its documented interface, then you can easily change +the underlying implementation. If they haven't, then they lose and +it's their fault for breaking the contract and voiding their warranty. + +To do this, we'll make another class, this one called Fullname. What's +the Fullname class look like? To answer that question, you have to +first figure out how you want to use it. How about we use it this way: + + $him = Person->new(); + $him->fullname->title("St"); + $him->fullname->christian("Thomas"); + $him->fullname->surname("Aquinas"); + $him->fullname->nickname("Tommy"); + printf "His normal name is %s\n", $him->name; + printf "But his real name is %s\n", $him->fullname->as_string; + +Ok. To do this, we'll change Person::new() so that it supports +a full name field this way: + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{FULLNAME} = Fullname->new(); + $self->{AGE} = undef; + $self->{PEERS} = []; + $self->{"_CENSUS"} = \$Census; + bless ($self, $class); + ++ ${ $self->{"_CENSUS"} }; + return $self; + } + + sub fullname { + my $self = shift; + return $self->{FULLNAME}; + } + +Then to support old code, define Person::name() this way: + + sub name { + my $self = shift; + return $self->{FULLNAME}->nickname(@_) + || $self->{FULLNAME}->christian(@_); + } + +Here's the Fullname class. We'll use the same technique +of using a hash reference to hold data fields, and methods +by the appropriate name to access them: + + package Fullname; + use strict; + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { + TITLE => undef, + CHRISTIAN => undef, + SURNAME => undef, + NICK => undef, + }; + bless ($self, $class); + return $self; + } + + sub christian { + my $self = shift; + if (@_) { $self->{CHRISTIAN} = shift } + return $self->{CHRISTIAN}; + } + + sub surname { + my $self = shift; + if (@_) { $self->{SURNAME} = shift } + return $self->{SURNAME}; + } + + sub nickname { + my $self = shift; + if (@_) { $self->{NICK} = shift } + return $self->{NICK}; + } + + sub title { + my $self = shift; + if (@_) { $self->{TITLE} = shift } + return $self->{TITLE}; + } + + sub as_string { + my $self = shift; + my $name = join(" ", @$self{'CHRISTIAN', 'SURNAME'}); + if ($self->{TITLE}) { + $name = $self->{TITLE} . " " . $name; + } + return $name; + } + + 1; + +Finally, here's the test program: + + #!/usr/bin/perl -w + use strict; + use Person; + sub END { show_census() } + + sub show_census () { + printf "Current population: %d\n", Person->population; + } + + Person->debug(1); + + show_census(); + + my $him = Person->new(); + + $him->fullname->christian("Thomas"); + $him->fullname->surname("Aquinas"); + $him->fullname->nickname("Tommy"); + $him->fullname->title("St"); + $him->age(1); + + printf "%s is really %s.\n", $him->name, $him->fullname; + printf "%s's age: %d.\n", $him->name, $him->age; + $him->happy_birthday; + printf "%s's age: %d.\n", $him->name, $him->age; + + show_census(); + +=head1 Inheritance + +Object-oriented programming systems all support some notion of +inheritance. Inheritance means allowing one class to piggy-back on +top of another one so you don't have to write the same code again and +again. It's about software reuse, and therefore related to Laziness, +the principal virtue of a programmer. (The import/export mechanisms in +traditional modules are also a form of code reuse, but a simpler one than +the true inheritance that you find in object modules.) + +Sometimes the syntax of inheritance is built into the core of the +language, and sometimes it's not. Perl has no special syntax for +specifying the class (or classes) to inherit from. Instead, it's all +strictly in the semantics. Each package can have a variable called @ISA, +which governs (method) inheritance. If you try to call a method on an +object or class, and that method is not found in that object's package, +Perl then looks to @ISA for other packages to go looking through in +search of the missing method. + +Like the special per-package variables recognized by Exporter (such as +@EXPORT, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, and $VERSION), the @ISA +array I<must> be a package-scoped global and not a file-scoped lexical +created via my(). Most classes have just one item in their @ISA array. +In this case, we have what's called "single inheritance", or SI for short. + +Consider this class: + + package Employee; + use Person; + @ISA = ("Person"); + 1; + +Not a lot to it, eh? All it's doing so far is loading in another +class and stating that this one will inherit methods from that +other class if need be. We have given it none of its own methods. +We rely upon an Employee to behave just like a Person. + +Setting up an empty class like this is called the "empty subclass test"; +that is, making a derived class that does nothing but inherit from a +base class. If the original base class has been designed properly, +then the new derived class can be used as a drop-in replacement for the +old one. This means you should be able to write a program like this: + + use Employee; + my $empl = Employee->new(); + $empl->name("Jason"); + $empl->age(23); + printf "%s is age %d.\n", $empl->name, $empl->age; + +By proper design, we mean always using the two-argument form of bless(), +avoiding direct access of global data, and not exporting anything. If you +look back at the Person::new() function we defined above, we were careful +to do that. There's a bit of package data used in the constructor, +but the reference to this is stored on the object itself and all other +methods access package data via that reference, so we should be ok. + +What do we mean by the Person::new() function -- isn't that actually +a method? Well, in principle, yes. A method is just a function that +expects as its first argument a class name (package) or object +(blessed reference). Person::new() is the function that both the +C<Person-E<gt>new()> method and the C<Employee-E<gt>new()> method end +up calling. Understand that while a method call looks a lot like a +function call, they aren't really quite the same, and if you treat them +as the same, you'll very soon be left with nothing but broken programs. +First, the actual underlying calling conventions are different: method +calls get an extra argument. Second, function calls don't do inheritance, +but methods do. + + Method Call Resulting Function Call + ----------- ------------------------ + Person->new() Person::new("Person") + Employee->new() Person::new("Employee") + +So don't use function calls when you mean to call a method. + +If an employee is just a Person, that's not all too very interesting. +So let's add some other methods. We'll give our employee +data fields to access their salary, their employee ID, and their +start date. + +If you're getting a little tired of creating all these nearly identical +methods just to get at the object's data, do not despair. Later, +we'll describe several different convenience mechanisms for shortening +this up. Meanwhile, here's the straight-forward way: + + sub salary { + my $self = shift; + if (@_) { $self->{SALARY} = shift } + return $self->{SALARY}; + } + + sub id_number { + my $self = shift; + if (@_) { $self->{ID} = shift } + return $self->{ID}; + } + + sub start_date { + my $self = shift; + if (@_) { $self->{START_DATE} = shift } + return $self->{START_DATE}; + } + +=head2 Overridden Methods + +What happens when both a derived class and its base class have the same +method defined? Well, then you get the derived class's version of that +method. For example, let's say that we want the peers() method called on +an employee to act a bit differently. Instead of just returning the list +of peer names, let's return slightly different strings. So doing this: + + $empl->peers("Peter", "Paul", "Mary"); + printf "His peers are: %s\n", join(", ", $empl->peers); + +will produce: + + His peers are: PEON=PETER, PEON=PAUL, PEON=MARY + +To do this, merely add this definition into the Employee.pm file: + + sub peers { + my $self = shift; + if (@_) { @{ $self->{PEERS} } = @_ } + return map { "PEON=\U$_" } @{ $self->{PEERS} }; + } + +There, we've just demonstrated the high-falutin' concept known in certain +circles as I<polymorphism>. We've taken on the form and behaviour of +an existing object, and then we've altered it to suit our own purposes. +This is a form of Laziness. (Getting polymorphed is also what happens +when the wizard decides you'd look better as a frog.) + +Every now and then you'll want to have a method call trigger both its +derived class (also known as "subclass") version as well as its base class +(also known as "superclass") version. In practice, constructors and +destructors are likely to want to do this, and it probably also makes +sense in the debug() method we showed previously. + +To do this, add this to Employee.pm: + + use Carp; + my $Debugging = 0; + + sub debug { + my $self = shift; + confess "usage: thing->debug(level)" unless @_ == 1; + my $level = shift; + if (ref($self)) { + $self->{"_DEBUG"} = $level; + } else { + $Debugging = $level; # whole class + } + Person::debug($self, $Debugging); # don't really do this + } + +As you see, we turn around and call the Person package's debug() function. +But this is far too fragile for good design. What if Person doesn't +have a debug() function, but is inheriting I<its> debug() method +from elsewhere? It would have been slightly better to say + + Person->debug($Debugging); + +But even that's got too much hard-coded. It's somewhat better to say + + $self->Person::debug($Debugging); + +Which is a funny way to say to start looking for a debug() method up +in Person. This strategy is more often seen on overridden object methods +than on overridden class methods. + +There is still something a bit off here. We've hard-coded our +superclass's name. This in particular is bad if you change which classes +you inherit from, or add others. Fortunately, the pseudoclass SUPER +comes to the rescue here. + + $self->SUPER::debug($Debugging); + +This way it starts looking in my class's @ISA. This only makes sense +from I<within> a method call, though. Don't try to access anything +in SUPER:: from anywhere else, because it doesn't exist outside +an overridden method call. + +Things are getting a bit complicated here. Have we done anything +we shouldn't? As before, one way to test whether we're designing +a decent class is via the empty subclass test. Since we already have +an Employee class that we're trying to check, we'd better get a new +empty subclass that can derive from Employee. Here's one: + + package Boss; + use Employee; # :-) + @ISA = qw(Employee); + +And here's the test program: + + #!/usr/bin/perl -w + use strict; + use Boss; + Boss->debug(1); + + my $boss = Boss->new(); + + $boss->fullname->title("Don"); + $boss->fullname->surname("Pichon Alvarez"); + $boss->fullname->christian("Federico Jesus"); + $boss->fullname->nickname("Fred"); + + $boss->age(47); + $boss->peers("Frank", "Felipe", "Faust"); + + printf "%s is age %d.\n", $boss->fullname, $boss->age; + printf "His peers are: %s\n", join(", ", $boss->peers); + +Running it, we see that we're still ok. If you'd like to dump out your +object in a nice format, somewhat like the way the 'x' command works in +the debugger, you could use the Data::Dumper module from CPAN this way: + + use Data::Dumper; + print "Here's the boss:\n"; + print Dumper($boss); + +Which shows us something like this: + + Here's the boss: + $VAR1 = bless( { + _CENSUS => \1, + FULLNAME => bless( { + TITLE => 'Don', + SURNAME => 'Pichon Alvarez', + NICK => 'Fred', + CHRISTIAN => 'Federico Jesus' + }, 'Fullname' ), + AGE => 47, + PEERS => [ + 'Frank', + 'Felipe', + 'Faust' + ] + }, 'Boss' ); + +Hm.... something's missing there. What about the salary, start date, +and ID fields? Well, we never set them to anything, even undef, so they +don't show up in the hash's keys. The Employee class has no new() method +of its own, and the new() method in Person doesn't know about Employees. +(Nor should it: proper OO design dictates that a subclass be allowed to +know about its immediate superclass, but never vice-versa.) So let's +fix up Employee::new() this way: + + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(); + $self->{SALARY} = undef; + $self->{ID} = undef; + $self->{START_DATE} = undef; + bless ($self, $class); # reconsecrate + return $self; + } + +Now if you dump out an Employee or Boss object, you'll find +that new fields show up there now. + +=head2 Multiple Inheritance + +Ok, at the risk of confusing beginners and annoying OO gurus, it's +time to confess that Perl's object system includes that controversial +notion known as multiple inheritance, or MI for short. All this means +is that rather than having just one parent class who in turn might +itself have a parent class, etc., that you can directly inherit from +two or more parents. It's true that some uses of MI can get you into +trouble, although hopefully not quite so much trouble with Perl as with +dubiously-OO languages like C++. + +The way it works is actually pretty simple: just put more than one package +name in your @ISA array. When it comes time for Perl to go finding +methods for your object, it looks at each of these packages in order. +Well, kinda. It's actually a fully recursive, depth-first order. +Consider a bunch of @ISA arrays like this: + + @First::ISA = qw( Alpha ); + @Second::ISA = qw( Beta ); + @Third::ISA = qw( First Second ); + +If you have an object of class Third: + + my $ob = Third->new(); + $ob->spin(); + +How do we find a spin() method (or a new() method for that matter)? +Because the search is depth-first, classes will be looked up +in the following order: Third, First, Alpha, Second, and Beta. + +In practice, few class modules have been seen that actually +make use of MI. One nearly always chooses simple containership of +one class within another over MI. That's why our Person +object I<contained> a Fullname object. That doesn't mean +it I<was> one. + +However, there is one particular area where MI in Perl is rampant: +borrowing another class's class methods. This is rather common, +especially with some bundled "objectless" classes, +like Exporter, DynaLoader, AutoLoader, and SelfLoader. These classes +do not provide constructors; they exist only so you may inherit their +class methods. (It's not entirely clear why inheritance was done +here rather than traditional module importation.) + +For example, here is the POSIX module's @ISA: + + package POSIX; + @ISA = qw(Exporter DynaLoader); + +The POSIX module isn't really an object module, but then, +neither are Exporter or DynaLoader. They're just lending their +classes' behaviours to POSIX. + +Why don't people use MI for object methods much? One reason is that +it can have complicated side-effects. For one thing, your inheritance +graph (no longer a tree) might converge back to the same base class. +Although Perl guards against recursive inheritance, merely having parents +who are related to each other via a common ancestor, incestuous though +it sounds, is not forbidden. What if in our Third class shown above we +wanted its new() method to also call both overridden constructors in its +two parent classes? The SUPER notation would only find the first one. +Also, what about if the Alpha and Beta classes both had a common ancestor, +like Nought? If you kept climbing up the inheritance tree calling +overridden methods, you'd end up calling Nought::new() twice, +which might well be a bad idea. + +=head2 UNIVERSAL: The Root of All Objects + +Wouldn't it be convenient if all objects were rooted at some ultimate +base class? That way you could give every object common methods without +having to go and add it to each and every @ISA. Well, it turns out that +you can. You don't see it, but Perl tacitly and irrevocably assumes +that there's an extra element at the end of @ISA: the class UNIVERSAL. +In version 5.003, there were no predefined methods there, but you could put +whatever you felt like into it. + +However, as of version 5.004 (or some subversive releases, like 5.003_08), +UNIVERSAL has some methods in it already. These are builtin to your Perl +binary, so they don't take any extra time to load. Predefined methods +include isa(), can(), and VERSION(). isa() tells you whether an object or +class "is" another one without having to traverse the hierarchy yourself: + + $has_io = $fd->isa("IO::Handle"); + $itza_handle = IO::Socket->isa("IO::Handle"); + +The can() method, called against that object or class, reports back +whether its string argument is a callable method name in that class. +In fact, it gives you back a function reference to that method: + + $his_print_method = $obj->can('as_string'); + +Finally, the VERSION method checks whether the class (or the object's +class) has a package global called $VERSION that's high enough, as in: + + Some_Module->VERSION(3.0); + $his_vers = $ob->VERSION(); + +However, we don't usually call VERSION ourselves. (Remember that an all +uppercase function name is a Perl convention that indicates that the +function will be automatically used by Perl in some way.) In this case, +it happens when you say + + use Some_Module 3.0; + +If you wanted to add version checking to your Person class explained +above, just add this to Person.pm: + + use vars qw($VERSION); + $VERSION = '1.1'; + +and then in Employee.pm could you can say + + use Employee 1.1; + +And it would make sure that you have at least that version number or +higher available. This is not the same as loading in that exact version +number. No mechanism currently exists for concurrent installation of +multiple versions of a module. Lamentably. + +=head1 Alternate Object Representations + +Nothing requires objects to be implemented as hash references. An object +can be any sort of reference so long as its referent has been suitably +blessed. That means scalar, array, and code references are also fair +game. + +A scalar would work if the object has only one datum to hold. An array +would work for most cases, but makes inheritance a bit dodgy because +you have to invent new indices for the derived classes. + +=head2 Arrays as Objects + +If the user of your class honors the contract and sticks to the advertised +interface, then you can change its underlying interface if you feel +like it. Here's another implementation that conforms to the same +interface specification. This time we'll use an array reference +instead of a hash reference to represent the object. + + package Person; + use strict; + + my($NAME, $AGE, $PEERS) = ( 0 .. 2 ); + + ############################################ + ## the object constructor (array version) ## + ############################################ + sub new { + my $self = []; + $self->[$NAME] = undef; # this is unnecessary + $self->[$AGE] = undef; # as is this + $self->[$PEERS] = []; # but this isn't, really + bless($self); + return $self; + } + + sub name { + my $self = shift; + if (@_) { $self->[$NAME] = shift } + return $self->[$NAME]; + } + + sub age { + my $self = shift; + if (@_) { $self->[$AGE] = shift } + return $self->[$AGE]; + } + + sub peers { + my $self = shift; + if (@_) { @{ $self->[$PEERS] } = @_ } + return @{ $self->[$PEERS] }; + } + + 1; # so the require or use succeeds + +You might guess that the array access would be a lot faster than the +hash access, but they're actually comparable. The array is a I<little> +bit faster, but not more than ten or fifteen percent, even when you +replace the variables above like $AGE with literal numbers, like 1. +A bigger difference between the two approaches can be found in memory use. +A hash representation takes up more memory than an array representation +because you have to allocate memory for the keys as well as for the values. +However, it really isn't that bad, especially since as of version 5.004, +memory is only allocated once for a given hash key, no matter how many +hashes have that key. It's expected that sometime in the future, even +these differences will fade into obscurity as more efficient underlying +representations are devised. + +Still, the tiny edge in speed (and somewhat larger one in memory) +is enough to make some programmers choose an array representation +for simple classes. There's still a little problem with +scalability, though, because later in life when you feel +like creating subclasses, you'll find that hashes just work +out better. + +=head2 Closures as Objects + +Using a code reference to represent an object offers some fascinating +possibilities. We can create a new anonymous function (closure) who +alone in all the world can see the object's data. This is because we +put the data into an anonymous hash that's lexically visible only to +the closure we create, bless, and return as the object. This object's +methods turn around and call the closure as a regular subroutine call, +passing it the field we want to affect. (Yes, +the double-function call is slow, but if you wanted fast, you wouldn't +be using objects at all, eh? :-) + +Use would be similar to before: + + use Person; + $him = Person->new(); + $him->name("Jason"); + $him->age(23); + $him->peers( [ "Norbert", "Rhys", "Phineas" ] ); + printf "%s is %d years old.\n", $him->name, $him->age; + print "His peers are: ", join(", ", @{$him->peers}), "\n"; + +but the implementation would be radically, perhaps even sublimely +different: + + package Person; + + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = { + NAME => undef, + AGE => undef, + PEERS => [], + }; + my $closure = sub { + my $field = shift; + if (@_) { $self->{$field} = shift } + return $self->{$field}; + }; + bless($closure, $class); + return $closure; + } + + sub name { &{ $_[0] }("NAME", @_[ 1 .. $#_ ] ) } + sub age { &{ $_[0] }("AGE", @_[ 1 .. $#_ ] ) } + sub peers { &{ $_[0] }("PEERS", @_[ 1 .. $#_ ] ) } + + 1; + +Because this object is hidden behind a code reference, it's probably a bit +mysterious to those whose background is more firmly rooted in standard +procedural or object-based programming languages than in functional +programming languages whence closures derive. The object +created and returned by the new() method is itself not a data reference +as we've seen before. It's an anonymous code reference that has within +it access to a specific version (lexical binding and instantiation) +of the object's data, which are stored in the private variable $self. +Although this is the same function each time, it contains a different +version of $self. + +When a method like C<$him-E<gt>name("Jason")> is called, its implicit +zeroth argument is the invoking object--just as it is with all method +calls. But in this case, it's our code reference (something like a +function pointer in C++, but with deep binding of lexical variables). +There's not a lot to be done with a code reference beyond calling it, so +that's just what we do when we say C<&{$_[0]}>. This is just a regular +function call, not a method call. The initial argument is the string +"NAME", and any remaining arguments are whatever had been passed to the +method itself. + +Once we're executing inside the closure that had been created in new(), +the $self hash reference suddenly becomes visible. The closure grabs +its first argument ("NAME" in this case because that's what the name() +method passed it), and uses that string to subscript into the private +hash hidden in its unique version of $self. + +Nothing under the sun will allow anyone outside the executing method to +be able to get at this hidden data. Well, nearly nothing. You I<could> +single step through the program using the debugger and find out the +pieces while you're in the method, but everyone else is out of luck. + +There, if that doesn't excite the Scheme folks, then I just don't know +what will. Translation of this technique into C++, Java, or any other +braindead-static language is left as a futile exercise for aficionados +of those camps. + +You could even add a bit of nosiness via the caller() function and +make the closure refuse to operate unless called via its own package. +This would no doubt satisfy certain fastidious concerns of programming +police and related puritans. + +If you were wondering when Hubris, the third principle virtue of a +programmer, would come into play, here you have it. (More seriously, +Hubris is just the pride in craftsmanship that comes from having written +a sound bit of well-designed code.) + +=head1 AUTOLOAD: Proxy Methods + +Autoloading is a way to intercept calls to undefined methods. An autoload +routine may choose to create a new function on the fly, either loaded +from disk or perhaps just eval()ed right there. This define-on-the-fly +strategy is why it's called autoloading. + +But that's only one possible approach. Another one is to just +have the autoloaded method itself directly provide the +requested service. When used in this way, you may think +of autoloaded methods as "proxy" methods. + +When Perl tries to call an undefined function in a particular package +and that function is not defined, it looks for a function in +that same package called AUTOLOAD. If one exists, it's called +with the same arguments as the original function would have had. +The fully-qualified name of the function is stored in that package's +global variable $AUTOLOAD. Once called, the function can do anything +it would like, including defining a new function by the right name, and +then doing a really fancy kind of C<goto> right to it, erasing itself +from the call stack. + +What does this have to do with objects? After all, we keep talking about +functions, not methods. Well, since a method is just a function with +an extra argument and some fancier semantics about where it's found, +we can use autoloading for methods, too. Perl doesn't start looking +for an AUTOLOAD method until it has exhausted the recursive hunt up +through @ISA, though. Some programmers have even been known to define +a UNIVERSAL::AUTOLOAD method to trap unresolved method calls to any +kind of object. + +=head2 Autoloaded Data Methods + +You probably began to get a little suspicious about the duplicated +code way back earlier when we first showed you the Person class, and +then later the Employee class. Each method used to access the +hash fields looked virtually identical. This should have tickled +that great programming virtue, Impatience, but for the time, +we let Laziness win out, and so did nothing. Proxy methods can cure +this. + +Instead of writing a new function every time we want a new data field, +we'll use the autoload mechanism to generate (actually, mimic) methods on +the fly. To verify that we're accessing a valid member, we will check +against an C<_permitted> (pronounced "under-permitted") field, which +is a reference to a file-scoped lexical (like a C file static) hash of permitted fields in this record +called %fields. Why the underscore? For the same reason as the _CENSUS +field we once used: as a marker that means "for internal use only". + +Here's what the module initialization code and class +constructor will look like when taking this approach: + + package Person; + use Carp; + use vars qw($AUTOLOAD); # it's a package global + + my %fields = ( + name => undef, + age => undef, + peers => undef, + ); + + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = { + _permitted => \%fields, + %fields, + }; + bless $self, $class; + return $self; + } + +If we wanted our record to have default values, we could fill those in +where current we have C<undef> in the %fields hash. + +Notice how we saved a reference to our class data on the object itself? +Remember that it's important to access class data through the object +itself instead of having any method reference %fields directly, or else +you won't have a decent inheritance. + +The real magic, though, is going to reside in our proxy method, which +will handle all calls to undefined methods for objects of class Person +(or subclasses of Person). It has to be called AUTOLOAD. Again, it's +all caps because it's called for us implicitly by Perl itself, not by +a user directly. + + sub AUTOLOAD { + my $self = shift; + my $type = ref($self) + or croak "$self is not an object"; + + my $name = $AUTOLOAD; + $name =~ s/.*://; # strip fully-qualified portion + + unless (exists $self->{_permitted}->{$name} ) { + croak "Can't access `$name' field in class $type"; + } + + if (@_) { + return $self->{$name} = shift; + } else { + return $self->{$name}; + } + } + +Pretty nifty, eh? All we have to do to add new data fields +is modify %fields. No new functions need be written. + +I could have avoided the C<_permitted> field entirely, but I +wanted to demonstrate how to store a reference to class data on the +object so you wouldn't have to access that class data +directly from an object method. + +=head2 Inherited Autoloaded Data Methods + +But what about inheritance? Can we define our Employee +class similarly? Yes, so long as we're careful enough. + +Here's how to be careful: + + package Employee; + use Person; + use strict; + use vars qw(@ISA); + @ISA = qw(Person); + + my %fields = ( + id => undef, + salary => undef, + ); + + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = bless $that->SUPER::new(), $class; + my($element); + foreach $element (keys %fields) { + $self->{_permitted}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + return $self; + } + +Once we've done this, we don't even need to have an +AUTOLOAD function in the Employee package, because +we'll grab Person's version of that via inheritance, +and it will all work out just fine. + +=head1 Metaclassical Tools + +Even though proxy methods can provide a more convenient approach to making +more struct-like classes than tediously coding up data methods as +functions, it still leaves a bit to be desired. For one thing, it means +you have to handle bogus calls that you don't mean to trap via your proxy. +It also means you have to be quite careful when dealing with inheritance, +as detailed above. + +Perl programmers have responded to this by creating several different +class construction classes. These metaclasses are classes +that create other classes. A couple worth looking at are +Class::Struct and Alias. These and other related metaclasses can be +found in the modules directory on CPAN. + +=head2 Class::Struct + +One of the older ones is Class::Struct. In fact, its syntax and +interface were sketched out long before perl5 even solidified into a +real thing. What it does is provide you a way to "declare" a class +as having objects whose fields are of a specific type. The function +that does this is called, not surprisingly enough, struct(). Because +structures or records are not base types in Perl, each time you want to +create a class to provide a record-like data object, you yourself have +to define a new() method, plus separate data-access methods for each of +that record's fields. You'll quickly become bored with this process. +The Class::Struct::struct() function alleviates this tedium. + +Here's a simple example of using it: + + use Class::Struct qw(struct); + use Jobbie; # user-defined; see below + + struct 'Fred' => { + one => '$', + many => '@', + profession => Jobbie, # calls Jobbie->new() + }; + + $ob = Fred->new; + $ob->one("hmmmm"); + + $ob->many(0, "here"); + $ob->many(1, "you"); + $ob->many(2, "go"); + print "Just set: ", $ob->many(2), "\n"; + + $ob->profession->salary(10_000); + +You can declare types in the struct to be basic Perl types, or +user-defined types (classes). User types will be initialized by calling +that class's new() method. + +Here's a real-world example of using struct generation. Let's say you +wanted to override Perl's idea of gethostbyname() and gethostbyaddr() so +that they would return objects that acted like C structures. We don't +care about high-falutin' OO gunk. All we want is for these objects to +act like structs in the C sense. + + use Socket; + use Net::hostent; + $h = gethostbyname("perl.com"); # object return + printf "perl.com's real name is %s, address %s\n", + $h->name, inet_ntoa($h->addr); + +Here's how to do this using the Class::Struct module. +The crux is going to be this call: + + struct 'Net::hostent' => [ # note bracket + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', + ]; + +Which creates object methods of those names and types. +It even creates a new() method for us. + +We could also have implemented our object this way: + + struct 'Net::hostent' => { # note brace + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', + }; + +and then Class::Struct would have used an anonymous hash as the object +type, instead of an anonymous array. The array is faster and smaller, +but the hash works out better if you eventually want to do inheritance. +Since for this struct-like object we aren't planning on inheritance, +this time we'll opt for better speed and size over better flexibility. + +Here's the whole implementation: + + package Net::hostent; + use strict; + + BEGIN { + use Exporter (); + use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); + @EXPORT = qw(gethostbyname gethostbyaddr gethost); + @EXPORT_OK = qw( + $h_name @h_aliases + $h_addrtype $h_length + @h_addr_list $h_addr + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + } + use vars @EXPORT_OK; + + # Class::Struct forbids use of @ISA + sub import { goto &Exporter::import } + + use Class::Struct qw(struct); + struct 'Net::hostent' => [ + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', + ]; + + sub addr { shift->addr_list->[0] } + + sub populate (@) { + return unless @_; + my $hob = new(); # Class::Struct made this! + $h_name = $hob->[0] = $_[0]; + @h_aliases = @{ $hob->[1] } = split ' ', $_[1]; + $h_addrtype = $hob->[2] = $_[2]; + $h_length = $hob->[3] = $_[3]; + $h_addr = $_[4]; + @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ]; + return $hob; + } + + sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) } + + sub gethostbyaddr ($;$) { + my ($addr, $addrtype); + $addr = shift; + require Socket unless @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::gethostbyaddr($addr, $addrtype)) + } + + sub gethost($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &gethostbyaddr(Socket::inet_aton(shift)); + } else { + &gethostbyname; + } + } + + 1; + +We've snuck in quite a fair bit of other concepts besides just dynamic +class creation, like overriding core functions, import/export bits, +function prototyping, short-cut function call via C<&whatever>, and +function replacement with C<goto &whatever>. These all mostly make +sense from the perspective of a traditional module, but as you can see, +we can also use them in an object module. + +You can look at other object-based, struct-like overrides of core +functions in the 5.004 release of Perl in File::stat, Net::hostent, +Net::netent, Net::protoent, Net::servent, Time::gmtime, Time::localtime, +User::grent, and User::pwent. These modules have a final component +that's all lowercase, by convention reserved for compiler pragmas, +because they affect the compilation and change a builtin function. +They also have the type names that a C programmer would most expect. + +=head2 Data Members as Variables + +If you're used to C++ objects, then you're accustomed to being able to +get at an object's data members as simple variables from within a method. +The Alias module provides for this, as well as a good bit more, such +as the possibility of private methods that the object can call but folks +outside the class cannot. + +Here's an example of creating a Person using the Alias module. +When you update these magical instance variables, you automatically +update value fields in the hash. Convenient, eh? + + package Person; + + # this is the same as before... + sub new { + my $that = shift; + my $class = ref($that) || $that; + my $self = { + NAME => undef, + AGE => undef, + PEERS => [], + }; + bless($self, $class); + return $self; + } + + use Alias qw(attr); + use vars qw($NAME $AGE $PEERS); + + sub name { + my $self = attr shift; + if (@_) { $NAME = shift; } + return $NAME; + } + + sub age { + my $self = attr shift; + if (@_) { $AGE = shift; } + return $AGE; + } + + sub peers { + my $self = attr shift; + if (@_) { @PEERS = @_; } + return @PEERS; + } + + sub exclaim { + my $self = attr shift; + return sprintf "Hi, I'm %s, age %d, working with %s", + $NAME, $AGE, join(", ", @PEERS); + } + + sub happy_birthday { + my $self = attr shift; + return ++$AGE; + } + +The need for the C<use vars> declaration is because what Alias does +is play with package globals with the same name as the fields. To use +globals while C<use strict> is in effect, you have to predeclare them. +These package variables are localized to the block enclosing the attr() +call just as if you'd used a local() on them. However, that means that +they're still considered global variables with temporary values, just +as with any other local(). + +It would be nice to combine Alias with +something like Class::Struct or Class::MethodMaker. + +=head2 NOTES + +=head2 Object Terminology + +In the various OO literature, it seems that a lot of different words +are used to describe only a few different concepts. If you're not +already an object programmer, then you don't need to worry about all +these fancy words. But if you are, then you might like to know how to +get at the same concepts in Perl. + +For example, it's common to call an object an I<instance> of a class +and to call those objects' methods I<instance methods>. Data fields +peculiar to each object are often called I<instance data> or I<object +attributes>, and data fields common to all members of that class are +I<class data>, I<class attributes>, or I<static data members>. + +Also, I<base class>, I<generic class>, and I<superclass> all describe +the same notion, whereas I<derived class>, I<specific class>, and +I<subclass> describe the other related one. + +C++ programmers have I<static methods> and I<virtual methods>, +but Perl only has I<class methods> and I<object methods>. +Actually, Perl only has methods. Whether a method gets used +as a class or object method is by usage only. You could accidentally +call a class method (one expecting a string argument) on an +object (one expecting a reference), or vice versa. + +Z<>From the C++ perspective, all methods in Perl are virtual. +This, by the way, is why they are never checked for function +prototypes in the argument list as regular builtin and user-defined +functions can be. + +Because a class is itself something of an object, Perl's classes can be +taken as describing both a "class as meta-object" (also called I<object +factory>) philosophy and the "class as type definition" (I<declaring> +behaviour, not I<defining> mechanism) idea. C++ supports the latter +notion, but not the former. + +=head1 SEE ALSO + +The following manpages will doubtless provide more +background for this one: +L<perlmod>, +L<perlref>, +L<perlobj>, +L<perlbot>, +L<perltie>, +and +L<overload>. + +=head1 COPYRIGHT + +I I<really> hate to have to say this, but recent unpleasant +experiences have mandated its inclusion: + + Copyright 1996 Tom Christiansen. All Rights Reserved. + +This work derives in part from the second edition of I<Programming Perl>. +Although destined for release as a manpage with the standard Perl +distribution, it is not public domain (nor is any of Perl and its docset: +publishers beware). It's expected to someday make its way into a revision +of the Camel Book. While it is copyright by me with all rights reserved, +permission is granted to freely distribute verbatim copies of this +document provided that no modifications outside of formatting be made, +and that this notice remain intact. You are permitted and encouraged to +use its code and derivatives thereof in your own source code for fun or +for profit as you see fit. But so help me, if in six months I find some +book out there with a hacked-up version of this material in it claiming to +be written by someone else, I'll tell all the world that you're a jerk. +Furthermore, your lawyer will meet my lawyer (or O'Reilly's) over lunch +to arrange for you to receive your just deserts. Count on it. + +=head2 Acknowledgments + +Thanks to +Larry Wall, +Roderick Schertler, +Gurusamy Sarathy, +Dean Roehrich, +Raphael Manfredi, +Brent Halsey, +Greg Bacon, +Brad Appleton, +and many others for their helpful comments. diff --git a/gnu/usr.bin/perl/pod/rofftoc b/gnu/usr.bin/perl/pod/rofftoc new file mode 100644 index 00000000000..a2d0e7ba204 --- /dev/null +++ b/gnu/usr.bin/perl/pod/rofftoc @@ -0,0 +1,66 @@ +# feed this into perl + eval 'exec perl -S $0 ${1+"$@"}' + if $running_under_some_shell; + +# Usage: rofftoc PerlTOC.xxx.raw +# +# Post-processes roffitall output. Called from roffitall to produce +# a formatted table of contents. +# +# Author: Tom Christiansen + +print <<'EOF'; +.de NP +'.sp 0.8i +.tl ''- % -'' +'bp +'sp 0.5i +.tl ''\fB\s+2Perl Table of Contents\s0\fR'' +'sp 0.3i +.. +.wh -1i NP +.af % i +.sp 0.5i +.tl ''\fB\s+5Perl Table of Contents\s0\fR'' +.sp 0.5i +.nf +.na +EOF +while (<>) { + #chomp; + s/Index://; + ($type, $page, $desc) = split ' ', $_, 3; + $desc =~ s/^"(.*)"$/$1/; + if ($type eq 'Title') { + ($name = $desc) =~ s/ .*//; + next; + } elsif ($type eq 'Name') { + #print STDERR $page, "\t", $desc; + print ".ne 5\n"; + print ".in 0\n"; + print ".sp\n"; + print ".ft B\n"; + print "$desc\n"; + print ".ft P\n"; + print ".in 5n\n"; + } elsif ($type eq 'Header') { + print ".br\n", $page, "\t", $desc; + } elsif ($type eq 'Subsection') { + print ".br\n", $page, "\t\t", $desc; + } elsif ($type eq 'Item') { + next if $desc =~ /\\bu/; + next unless $name =~ /POSIX|func/i; + print ".br\n", $page, "\t\t\t", $desc; + } +} +__END__ +Index:Title 1 "PERL 1" +Index:Name 1 "perl - Practical Extraction and Report Language" +Index:Header 1 "NAME" +Index:Header 1 "SYNOPSIS" +Index:Header 2 "DESCRIPTION" +Index:Item 2 "\(bu Many usability enhancements" +Index:Item 2 "\(bu Simplified grammar" +Index:Item 2 "\(bu Lexical scoping" +Index:Item 2 "\(bu Arbitrarily nested data structures" +Index:Item 2 "\(bu Modularity and reusability" diff --git a/gnu/usr.bin/perl/qnx/ar b/gnu/usr.bin/perl/qnx/ar new file mode 100644 index 00000000000..b46549abd1a --- /dev/null +++ b/gnu/usr.bin/perl/qnx/ar @@ -0,0 +1,33 @@ +#! /bin/sh +#__USAGE +#%C key library name ... +# Crude cover for wlib to be compatible with ar +# Supports the following key letters: +# qcru +# ru replace existing modules. u indicates only replace +# those which are newer +# c create the library (kinda moot) +# q quickly append to the end. +# +#This is a crude cover, but it has proved sufficient for many +#ports. Rather than attempt to implement subtleties of the +#ar syntax, I simply create a new library under all +#circumstances. A much more thorough cover is available from +#http://www.fdma.com/pub/qnx/porting/ar +# +#Note that Watcom 10.6 supports ar directly, so this +#cover is not necessary. +# +#Increased the record size to 32 to accomodate a large library +#in the perl 5.003 distribution +# +#Submitted by Norton T. Allen (allen@huarp.harvard.edu) + +if [ $# -lt 3 ]; then + use $0 + exit 1 +fi +shift +library=$1 +shift +wlib -p=32 -n $library `for i in $*; do echo "+$i \\c"; done` diff --git a/gnu/usr.bin/perl/qnx/cpp b/gnu/usr.bin/perl/qnx/cpp new file mode 100644 index 00000000000..6459af249f5 --- /dev/null +++ b/gnu/usr.bin/perl/qnx/cpp @@ -0,0 +1,24 @@ +#! /bin/sh +#__USAGE +#%C [-P] [-C] other options +# cpp is a wrapper for wcc to make it work like other cpp's +# -P omit #line directives from the output +# -C pass comments through to the output +# +#Submitted by Norton T. Allen (allen@huarp.harvard.edu) + +typeset lines=l comments="" redir="" +while :; do + case $1 in + -P) lines=""; shift; continue;; + -C) comments=c; shift; continue;; + esac + break +done +if [ ! -t 0 ]; then + cat >.$$.c + redir=.$$.c +fi +cc -c -Wc,-p$lines$comments -Wc,-pw=0 $* $redir | + awk 'NR>1||NF>0 {sub("^ ","");print}' +[ -n "$redir" ] && rm -f $redir diff --git a/gnu/usr.bin/perl/t/comp/colon.t b/gnu/usr.bin/perl/t/comp/colon.t new file mode 100644 index 00000000000..d2c64fe4c53 --- /dev/null +++ b/gnu/usr.bin/perl/t/comp/colon.t @@ -0,0 +1,138 @@ +#!./perl + +# +# Ensure that syntax using colons (:) is parsed correctly. +# The tests are done on the following tokens (by default): +# ABC LABEL XYZZY m q qq qw qx s tr y AUTOLOAD and alarm +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +$_ = ''; # to avoid undef warning on m// etc. + +sub ok { + my($test,$ok) = @_; + print "not " unless $ok; + print "ok $test\n"; +} + +$SIG{__WARN__} = sub { 1; }; # avoid some spurious warnings + +print "1..25\n"; + +ok 1, (eval "package ABC; sub zyx {1}; 1;" and + eval "ABC::zyx" and + not eval "ABC:: eq ABC||" and + not eval "ABC::: >= 0"); + +ok 2, (eval "package LABEL; sub zyx {1}; 1;" and + eval "LABEL::zyx" and + not eval "LABEL:: eq LABEL||" and + not eval "LABEL::: >= 0"); + +ok 3, (eval "package XYZZY; sub zyx {1}; 1;" and + eval "XYZZY::zyx" and + not eval "XYZZY:: eq XYZZY||" and + not eval "XYZZY::: >= 0"); + +ok 4, (eval "package m; sub zyx {1}; 1;" and + not eval "m::zyx" and + eval "m:: eq m||" and + not eval "m::: >= 0"); + +ok 5, (eval "package q; sub zyx {1}; 1;" and + not eval "q::zyx" and + eval "q:: eq q||" and + not eval "q::: >= 0"); + +ok 6, (eval "package qq; sub zyx {1}; 1;" and + not eval "qq::zyx" and + eval "qq:: eq qq||" and + not eval "qq::: >= 0"); + +ok 7, (eval "package qw; sub zyx {1}; 1;" and + not eval "qw::zyx" and + eval "qw:: eq qw||" and + not eval "qw::: >= 0"); + +ok 8, (eval "package qx; sub zyx {1}; 1;" and + not eval "qx::zyx" and + eval "qx:: eq qx||" and + not eval "qx::: >= 0"); + +ok 9, (eval "package s; sub zyx {1}; 1;" and + not eval "s::zyx" and + not eval "s:: eq s||" and + eval "s::: >= 0"); + +ok 10, (eval "package tr; sub zyx {1}; 1;" and + not eval "tr::zyx" and + not eval "tr:: eq tr||" and + eval "tr::: >= 0"); + +ok 11, (eval "package y; sub zyx {1}; 1;" and + not eval "y::zyx" and + not eval "y:: eq y||" and + eval "y::: >= 0"); + +ok 12, (eval "ABC:1" and + not eval "ABC:echo: eq ABC|echo|" and + not eval "ABC:echo:ohce: >= 0"); + +ok 13, (eval "LABEL:1" and + not eval "LABEL:echo: eq LABEL|echo|" and + not eval "LABEL:echo:ohce: >= 0"); + +ok 14, (eval "XYZZY:1" and + not eval "XYZZY:echo: eq XYZZY|echo|" and + not eval "XYZZY:echo:ohce: >= 0"); + +ok 15, (not eval "m:1" and + eval "m:echo: eq m|echo|" and + not eval "m:echo:ohce: >= 0"); + +ok 16, (not eval "q:1" and + eval "q:echo: eq q|echo|" and + not eval "q:echo:ohce: >= 0"); + +ok 17, (not eval "qq:1" and + eval "qq:echo: eq qq|echo|" and + not eval "qq:echo:ohce: >= 0"); + +ok 18, (not eval "qw:1" and + eval "qw:echo: eq qw|echo|" and + not eval "qw:echo:ohce: >= 0"); + +ok 19, (not eval "qx:1" and + eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn + not eval "qx:echo:ohce: >= 0"); + +ok 20, (not eval "s:1" and + not eval "s:echo: eq s|echo|" and + eval "s:echo:ohce: >= 0"); + +ok 21, (not eval "tr:1" and + not eval "tr:echo: eq tr|echo|" and + eval "tr:echo:ohce: >= 0"); + +ok 22, (not eval "y:1" and + not eval "y:echo: eq y|echo|" and + eval "y:echo:ohce: >= 0"); + +ok 23, (eval "AUTOLOAD:1" and + not eval "AUTOLOAD:echo: eq AUTOLOAD|echo|" and + not eval "AUTOLOAD:echo:ohce: >= 0"); + +ok 24, (eval "and:1" and + not eval "and:echo: eq and|echo|" and + not eval "and:echo:ohce: >= 0"); + +ok 25, (eval "alarm:1" and + not eval "alarm:echo: eq alarm|echo|" and + not eval "alarm:echo:ohce: >= 0"); diff --git a/gnu/usr.bin/perl/t/comp/proto.t b/gnu/usr.bin/perl/t/comp/proto.t new file mode 100644 index 00000000000..d1cfede8af9 --- /dev/null +++ b/gnu/usr.bin/perl/t/comp/proto.t @@ -0,0 +1,390 @@ +#!./perl +# +# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> +# +# So far there are tests for the following prototypes. +# none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) +# +# It is impossible to test every prototype that can be specified, but +# we should test as many as we can. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +print "1..76\n"; + +my $i = 1; + +sub testing (&$) { + my $p = prototype(shift); + my $c = shift; + my $what = defined $c ? '(' . $p . ')' : 'no prototype'; + print '#' x 25,"\n"; + print '# Testing ',$what,"\n"; + print '#' x 25,"\n"; + print "not " + if((defined($p) && defined($c) && $p ne $c) + || (defined($p) != defined($c))); + printf "ok %d\n",$i++; +} + +@_ = qw(a b c d); +my @array; +my %hash; + +## +## +## + +testing \&no_proto, undef; + +sub no_proto { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 0 == no_proto(); +printf "ok %d\n",$i++; + +print "not " unless 1 == no_proto(5); +printf "ok %d\n",$i++; + +print "not " unless 4 == &no_proto; +printf "ok %d\n",$i++; + +print "not " unless 1 == no_proto +6; +printf "ok %d\n",$i++; + +print "not " unless 4 == no_proto(@_); +printf "ok %d\n",$i++; + +## +## +## + + +testing \&no_args, ''; + +sub no_args () { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 0 == no_args(); +printf "ok %d\n",$i++; + +print "not " unless 0 == no_args; +printf "ok %d\n",$i++; + +print "not " unless 5 == no_args +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &no_args; +printf "ok %d\n",$i++; + +print "not " unless 2 == &no_args(1,2); +printf "ok %d\n",$i++; + +eval "no_args(1)"; +print "not " unless $@; +printf "ok %d\n",$i++; + +## +## +## + +testing \&one_args, '$'; + +sub one_args ($) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == one_args(1); +printf "ok %d\n",$i++; + +print "not " unless 1 == one_args +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &one_args; +printf "ok %d\n",$i++; + +print "not " unless 2 == &one_args(1,2); +printf "ok %d\n",$i++; + +eval "one_args(1,2)"; +print "not " unless $@; +printf "ok %d\n",$i++; + +eval "one_args()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub one_a_args ($) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ == 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +one_a_args(@_); + +## +## +## + +testing \&over_one_args, '$@'; + +sub over_one_args ($@) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == over_one_args(1); +printf "ok %d\n",$i++; + +print "not " unless 2 == over_one_args(1,2); +printf "ok %d\n",$i++; + +print "not " unless 1 == over_one_args +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &over_one_args; +printf "ok %d\n",$i++; + +print "not " unless 2 == &over_one_args(1,2); +printf "ok %d\n",$i++; + +print "not " unless 5 == &over_one_args(1,@_); +printf "ok %d\n",$i++; + +eval "over_one_args()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub over_one_a_args ($@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ >= 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +over_one_a_args(@_); +over_one_a_args(@_,1); +over_one_a_args(@_,1,2); +over_one_a_args(@_,@_); + +## +## +## + +testing \&scalar_and_hash, '$%'; + +sub scalar_and_hash ($%) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == scalar_and_hash(1); +printf "ok %d\n",$i++; + +print "not " unless 3 == scalar_and_hash(1,2,3); +printf "ok %d\n",$i++; + +print "not " unless 1 == scalar_and_hash +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &scalar_and_hash; +printf "ok %d\n",$i++; + +print "not " unless 2 == &scalar_and_hash(1,2); +printf "ok %d\n",$i++; + +print "not " unless 5 == &scalar_and_hash(1,@_); +printf "ok %d\n",$i++; + +eval "scalar_and_hash()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub scalar_and_hash_a ($@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ >= 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +scalar_and_hash_a(@_); +scalar_and_hash_a(@_,1); +scalar_and_hash_a(@_,1,2); +scalar_and_hash_a(@_,@_); + +## +## +## + +testing \&one_or_two, '$;$'; + +sub one_or_two ($;$) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_) +} + +print "not " unless 1 == one_or_two(1); +printf "ok %d\n",$i++; + +print "not " unless 2 == one_or_two(1,3); +printf "ok %d\n",$i++; + +print "not " unless 1 == one_or_two +5; +printf "ok %d\n",$i++; + +print "not " unless 4 == &one_or_two; +printf "ok %d\n",$i++; + +print "not " unless 3 == &one_or_two(1,2,3); +printf "ok %d\n",$i++; + +print "not " unless 5 == &one_or_two(1,@_); +printf "ok %d\n",$i++; + +eval "one_or_two()"; +print "not " unless $@; +printf "ok %d\n",$i++; + +eval "one_or_two(1,2,3)"; +print "not " unless $@; +printf "ok %d\n",$i++; + +sub one_or_two_a ($;$) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ >= 1 && $_[0] == 4; + printf "ok %d\n",$i++; +} + +one_or_two_a(@_); +one_or_two_a(@_,1); +one_or_two_a(@_,@_); + +## +## +## + +testing \&a_sub, '&'; + +sub a_sub (&) { + print "# \@_ = (",join(",",@_),")\n"; + &{$_[0]}; +} + +sub tmp_sub_1 { printf "ok %d\n",$i++ } + +a_sub { printf "ok %d\n",$i++ }; +a_sub \&tmp_sub_1; + +@array = ( \&tmp_sub_1 ); +eval 'a_sub @array'; +print "not " unless $@; +printf "ok %d\n",$i++; + +## +## +## + +testing \&sub_aref, '&\@'; + +sub sub_aref (&\@) { + print "# \@_ = (",join(",",@_),")\n"; + my($sub,$array) = @_; + print "not " unless @_ == 2 && @{$array} == 4; + print map { &{$sub}($_) } @{$array} +} + +@array = (qw(O K)," ", $i++); +sub_aref { lc shift } @array; +print "\n"; + +## +## +## + +testing \&sub_array, '&@'; + +sub sub_array (&@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless @_ == 5; + my $sub = shift; + print map { &{$sub}($_) } @_ +} + +@array = (qw(O K)," ", $i++); +sub_array { lc shift } @array; +print "\n"; + +## +## +## + +testing \&a_hash, '%'; + +sub a_hash (%) { + print "# \@_ = (",join(",",@_),")\n"; + scalar(@_); +} + +print "not " unless 1 == a_hash 'a'; +printf "ok %d\n",$i++; + +print "not " unless 2 == a_hash 'a','b'; +printf "ok %d\n",$i++; + +## +## +## + +testing \&a_hash_ref, '\%'; + +sub a_hash_ref (\%) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless ref($_[0]) && $_[0]->{'a'}; + printf "ok %d\n",$i++; + $_[0]->{'b'} = 2; +} + +%hash = ( a => 1); +a_hash_ref %hash; +print "not " unless $hash{'b'} == 2; +printf "ok %d\n",$i++; + +## +## +## + +testing \&an_array_ref, '\@'; + +sub an_array_ref (\@) { + print "# \@_ = (",join(",",@_),")\n"; + print "not " unless ref($_[0]) && 1 == @{$_[0]}; + printf "ok %d\n",$i++; + @{$_[0]} = (qw(ok)," ",$i++,"\n"); +} + +@array = ('a'); +an_array_ref @array; +print "not " unless @array == 4; +print @array; + +# correctly note too-short parameter lists that don't end with '$', +# a possible regression. + +sub foo1 ($\@); +eval q{ foo1 "s" }; +print "not " unless $@ =~ /^Not enough/; +print "ok ", $i++, "\n"; + +sub foo2 ($\%); +eval q{ foo2 "s" }; +print "not " unless $@ =~ /^Not enough/; +print "ok ", $i++, "\n"; diff --git a/gnu/usr.bin/perl/t/comp/redef.t b/gnu/usr.bin/perl/t/comp/redef.t new file mode 100644 index 00000000000..07e978bb866 --- /dev/null +++ b/gnu/usr.bin/perl/t/comp/redef.t @@ -0,0 +1,80 @@ +#!./perl -w +# +# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> + +BEGIN { + $warn = ""; + $SIG{__WARN__} = sub { $warn .= join("",@_) } +} + +sub ok ($$) { + print $_[1] ? "ok " : "not ok ", $_[0], "\n"; +} + +print "1..18\n"; + +my $NEWPROTO = 'Prototype mismatch:'; + +sub sub0 { 1 } +sub sub0 { 2 } + +ok 1, $warn =~ s/Subroutine sub0 redefined[^\n]+\n//s; + +sub sub1 { 1 } +sub sub1 () { 2 } + +ok 2, $warn =~ s/$NEWPROTO \Qsub main::sub1 vs ()\E[^\n]+\n//s; +ok 3, $warn =~ s/Subroutine sub1 redefined[^\n]+\n//s; + +sub sub2 { 1 } +sub sub2 ($) { 2 } + +ok 4, $warn =~ s/$NEWPROTO \Qsub main::sub2 vs ($)\E[^\n]+\n//s; +ok 5, $warn =~ s/Subroutine sub2 redefined[^\n]+\n//s; + +sub sub3 () { 1 } +sub sub3 { 2 } + +ok 6, $warn =~ s/$NEWPROTO \Qsub main::sub3 () vs none\E[^\n]+\n//s; +ok 7, $warn =~ s/Constant subroutine sub3 redefined[^\n]+\n//s; + +sub sub4 () { 1 } +sub sub4 () { 2 } + +ok 8, $warn =~ s/Constant subroutine sub4 redefined[^\n]+\n//s; + +sub sub5 () { 1 } +sub sub5 ($) { 2 } + +ok 9, $warn =~ s/$NEWPROTO \Qsub main::sub5 () vs ($)\E[^\n]+\n//s; +ok 10, $warn =~ s/Constant subroutine sub5 redefined[^\n]+\n//s; + +sub sub6 ($) { 1 } +sub sub6 { 2 } + +ok 11, $warn =~ s/$NEWPROTO \Qsub main::sub6 ($) vs none\E[^\n]+\n//s; +ok 12, $warn =~ s/Subroutine sub6 redefined[^\n]+\n//s; + +sub sub7 ($) { 1 } +sub sub7 () { 2 } + +ok 13, $warn =~ s/$NEWPROTO \Qsub main::sub7 ($) vs ()\E[^\n]+\n//s; +ok 14, $warn =~ s/Subroutine sub7 redefined[^\n]+\n//s; + +sub sub8 ($) { 1 } +sub sub8 ($) { 2 } + +ok 15, $warn =~ s/Subroutine sub8 redefined[^\n]+\n//s; + +sub sub9 ($@) { 1 } +sub sub9 ($) { 2 } + +ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s; +ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s; + +ok 18, $_ eq ''; + +# If we got any errors that we were not expecting, then print them +print $_ if length $_; + + diff --git a/gnu/usr.bin/perl/t/comp/use.t b/gnu/usr.bin/perl/t/comp/use.t new file mode 100644 index 00000000000..a6ce2a4d565 --- /dev/null +++ b/gnu/usr.bin/perl/t/comp/use.t @@ -0,0 +1,101 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..14\n"; + +my $i = 1; + +eval "use 5.000;"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval sprintf "use %.5f;", $]; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + + +eval sprintf "use %.5f;", $] - 0.000001; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval sprintf("use %.5f;", $] + 1); +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + +eval sprintf "use %.5f;", $] + 0.00001; +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + + + +use lib; # I know that this module will be there. + + +local $lib::VERSION = 1.0; + +eval "use lib 0.9"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval "use lib 1.0"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +eval "use lib 1.01"; +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + + +eval "use lib 0.9 qw(fred)"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +print "not " unless $INC[0] eq "fred"; +print "ok ",$i++,"\n"; + +eval "use lib 1.0 qw(joe)"; +if ($@) { + print STDERR $@,"\n"; + print "not "; +} +print "ok ",$i++,"\n"; + +print "not " unless $INC[0] eq "joe"; +print "ok ",$i++,"\n"; + +eval "use lib 1.01 qw(freda)"; +unless ($@) { + print "not "; +} +print "ok ",$i++,"\n"; + +print "not " if $INC[0] eq "freda"; +print "ok ",$i++,"\n"; diff --git a/gnu/usr.bin/perl/t/io/read.t b/gnu/usr.bin/perl/t/io/read.t new file mode 100644 index 00000000000..b27fde17c7b --- /dev/null +++ b/gnu/usr.bin/perl/t/io/read.t @@ -0,0 +1,26 @@ +#!./perl + +# $RCSfile$ + +print "1..1\n"; + +open(A,"+>a"); +print A "_"; +seek(A,0,0); + +$b = "abcd"; +$b = ""; + +read(A,$b,1,4); + +close(A); + +unlink("a"); + +if ($b eq "\000\000\000\000_") { + print "ok 1\n"; +} else { # Probably "\000bcd_" + print "not ok 1\n"; +} + +unlink 'a'; diff --git a/gnu/usr.bin/perl/t/lib/abbrev.t b/gnu/usr.bin/perl/t/lib/abbrev.t new file mode 100644 index 00000000000..fb5a9841eb1 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/abbrev.t @@ -0,0 +1,51 @@ +#!./perl + +print "1..7\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Text::Abbrev; + +print "ok 1\n"; + +# old style as reference +local(%x); +my @z = qw(list edit send abort gripe listen); +abbrev(*x, @z); +my $r = join ':', sort keys %x; +print "not " if exists $x{'l'} || + exists $x{'li'} || + exists $x{'lis'}; +print "ok 2\n"; + +print "not " unless $x{'list'} eq 'list' && + $x{'liste'} eq 'listen' && + $x{'listen'} eq 'listen'; +print "ok 3\n"; + +print "not " unless $x{'a'} eq 'abort' && + $x{'ab'} eq 'abort' && + $x{'abo'} eq 'abort' && + $x{'abor'} eq 'abort' && + $x{'abort'} eq 'abort'; +print "ok 4\n"; + +my $test = 5; + +# wantarray +my %y = abbrev @z; +my $s = join ':', sort keys %y; +print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; + +my $y = abbrev @z; +$s = join ':', sort keys %$y; +print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; + +%y = (); +abbrev \%y, @z; + +$s = join ':', sort keys %y; +print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++; diff --git a/gnu/usr.bin/perl/t/lib/autoloader.t b/gnu/usr.bin/perl/t/lib/autoloader.t new file mode 100644 index 00000000000..b1622a8ae2e --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/autoloader.t @@ -0,0 +1,100 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + $dir = "auto-$$"; + @INC = ("./$dir", "../lib"); +} + +print "1..9\n"; + +# First we must set up some autoloader files +mkdir $dir, 0755 or die "Can't mkdir $dir: $!"; +mkdir "$dir/auto", 0755 or die "Can't mkdir: $!"; +mkdir "$dir/auto/Foo", 0755 or die "Can't mkdir: $!"; + +open(FOO, ">$dir/auto/Foo/foo.al") or die; +print FOO <<'EOT'; +package Foo; +sub foo { shift; shift || "foo" } +1; +EOT +close(FOO); + +open(BAR, ">$dir/auto/Foo/bar.al") or die; +print BAR <<'EOT'; +package Foo; +sub bar { shift; shift || "bar" } +1; +EOT +close(BAR); + +open(BAZ, ">$dir/auto/Foo/bazmarkhian.al") or die; +print BAZ <<'EOT'; +package Foo; +sub bazmarkhianish { shift; shift || "baz" } +1; +EOT +close(BAZ); + +# Let's define the package +package Foo; +require AutoLoader; +@ISA=qw(AutoLoader); + +sub new { bless {}, shift }; + +package main; + +$foo = new Foo; + +print "not " unless $foo->foo eq 'foo'; # autoloaded first time +print "ok 1\n"; + +print "not " unless $foo->foo eq 'foo'; # regular call +print "ok 2\n"; + +# Try an undefined method +eval { + $foo->will_fail; +}; +print "not " unless $@ =~ /^Can't locate/; +print "ok 3\n"; + +# Used to be trouble with this +eval { + my $foo = new Foo; + die "oops"; +}; +print "not " unless $@ =~ /oops/; +print "ok 4\n"; + +# Pass regular expression variable to autoloaded function. This used +# to go wrong because AutoLoader used regular expressions to generate +# autoloaded filename. +"foo" =~ /(\w+)/; +print "not " unless $1 eq 'foo'; +print "ok 5\n"; + +print "not " unless $foo->bar($1) eq 'foo'; +print "ok 6\n"; + +print "not " unless $foo->bar($1) eq 'foo'; +print "ok 7\n"; + +print "not " unless $foo->bazmarkhianish($1) eq 'foo'; +print "ok 8\n"; + +print "not " unless $foo->bazmarkhianish($1) eq 'foo'; +print "ok 9\n"; + +# cleanup +END { +return unless $dir && -d $dir; +unlink "$dir/auto/Foo/foo.al"; +unlink "$dir/auto/Foo/bar.al"; +unlink "$dir/auto/Foo/bazmarkhian.al"; +rmdir "$dir/auto/Foo"; +rmdir "$dir/auto"; +rmdir "$dir"; +} diff --git a/gnu/usr.bin/perl/t/lib/basename.t b/gnu/usr.bin/perl/t/lib/basename.t new file mode 100644 index 00000000000..860b3379b43 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/basename.t @@ -0,0 +1,121 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use File::Basename qw(fileparse basename dirname); + +print "1..34\n"; + +# import correctly? +print +(defined(&basename) && !defined(&fileparse_set_fstype) ? + '' : 'not '),"ok 1\n"; + +# set fstype -- should replace non-null default +print +(length(File::Basename::fileparse_set_fstype('unix')) ? + '' : 'not '),"ok 2\n"; + +# Unix syntax tests +($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+'); +if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') { + print "ok 3\n"; +} +else { + print "not ok 3 |$base|$path|$type|\n"; +} +print +(basename('/arma/virumque.cano') eq 'virumque.cano' ? + '' : 'not '),"ok 4\n"; +print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n"; +print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n"; +print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n"; + + +# set fstype -- should replace non-null default +print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ? + '' : 'not '),"ok 8\n"; + +# VMS syntax tests +($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+'); +if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') { + print "ok 9\n"; +} +else { + print "not ok 9 |$base|$path|$type|\n"; +} +print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ? + '' : 'not '),"ok 10\n"; +print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ? + '' : 'not '),"ok 11\n"; +print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ? + '' : 'not '),"ok 12\n"; +print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n"; +$ENV{DEFAULT} = '' unless exists $ENV{DEFAULT}; +print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n"; +print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n"; + +# set fstype -- should replace non-null default +print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ? + '' : 'not '),"ok 16\n"; + +# MSDOS syntax tests +($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+'); +if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') { + print "ok 17\n"; +} +else { + print "not ok 17 |$base|$path|$type|\n"; +} +print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ? + '' : 'not '),"ok 18\n"; +print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ? + '' : 'not '),"ok 19\n"; +print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n"; +print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n"; + +# Yes "/" is a legal path separator under MSDOS +basename("lib/File/Basename.pm") eq "Basename.pm" or print "not "; +print "ok 22\n"; + + + +# set fstype -- should replace non-null default +print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ? + '' : 'not '),"ok 23\n"; + +# MacOS syntax tests +($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+'); +if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') { + print "ok 24\n"; +} +else { + print "not ok 24 |$base|$path|$type|\n"; +} +print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ? + '' : 'not '),"ok 25\n"; +print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ? + '' : 'not '),"ok 26\n"; +print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 27\n"; +print +(dirname(':') eq ':' ? '' : 'not '),"ok 28\n"; + + +# Check quoting of metacharacters in suffix arg by basename() +print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ? + '' : 'not '),"ok 29\n"; +print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ? + '' : 'not '),"ok 30\n"; + +# extra tests for a few specific bugs + +File::Basename::fileparse_set_fstype 'MSDOS'; +# perl5.003_18 gives C:/perl/.\ +print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n"; +# perl5.003_18 gives C:\perl\ +print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n"; + +File::Basename::fileparse_set_fstype 'UNIX'; +# perl5.003_18 gives '.' +print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n"; +# perl5.003_18 gives '/perl/lib' +print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n"; diff --git a/gnu/usr.bin/perl/t/lib/checktree.t b/gnu/usr.bin/perl/t/lib/checktree.t new file mode 100644 index 00000000000..b5426ca261e --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/checktree.t @@ -0,0 +1,19 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..1\n"; + +use File::CheckTree; + +# We assume that we run from the perl "t" directory. + +validate q{ + lib -d || die + lib/checktree.t -f || die +}; + +print "ok 1\n"; diff --git a/gnu/usr.bin/perl/t/lib/complex.t b/gnu/usr.bin/perl/t/lib/complex.t new file mode 100644 index 00000000000..2a01859b989 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/complex.t @@ -0,0 +1,818 @@ +#!./perl + +# $RCSfile: complex.t,v $ +# +# Regression tests for the Math::Complex pacakge +# -- Raphael Manfredi September 1996 +# -- Jarkko Hietaniemi March-October 1997 +# -- Daniel S. Lewart September-October 1997 + +$VERSION = '1.05'; + +# $Id: complex.t,v 1.1 1997/11/30 08:00:23 millert Exp $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Math::Complex; + +my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); + +$test = 0; +$| = 1; +my @script = ( + 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' . + "\n\n" +); +my $eps = 1e-11; + +while (<DATA>) { + s/^\s+//; + next if $_ eq '' || /^\#/; + chomp; + $test_set = 0; # Assume not a test over a set of values + if (/^&(.+)/) { + $op = $1; + next; + } + elsif (/^\{(.+)\}/) { + set($1, \@set, \@val); + next; + } + elsif (s/^\|//) { + $test_set = 1; # Requests we loop over the set... + } + my @args = split(/:/); + if ($test_set == 1) { + my $i; + for ($i = 0; $i < @set; $i++) { + # complex number + $target = $set[$i]; + # textual value as found in set definition + $zvalue = $val[$i]; + test($zvalue, $target, @args); + } + } else { + test($op, undef, @args); + } +} + +# test the divbyzeros + +sub test_dbz { + for my $op (@_) { + $test++; + +# push(@script, qq(print "# '$op'\n";)); + push(@script, qq(eval '$op';)); + push(@script, qq(print 'not ' unless (\$@ =~ /Division by zero/);)); + push(@script, qq( print "ok $test\\n";\n)); + } +} + +# test the logofzeros + +sub test_loz { + for my $op (@_) { + $test++; + +# push(@script, qq(print "# '$op'\n";)); + push(@script, qq(eval '$op';)); + push(@script, qq(print 'not ' unless (\$@ =~ /Logarithm of zero/);)); + push(@script, qq( print "ok $test\\n";\n)); + } +} + +my $minusi = cplx(0, -1); + +test_dbz( + 'i/0', +# 'tan(pi/2)', # may succeed thanks to floating point inaccuracies +# 'sec(pi/2)', # may succeed thanks to floating point inaccuracies + 'csc(0)', + 'cot(0)', + 'atan(i)', + 'atan($minusi)', + 'asec(0)', + 'acsc(0)', + 'acot(i)', + 'acot($minusi)', +# 'tanh(pi/2)', # may succeed thanks to floating point inaccuracies +# 'sech(pi/2)', # may succeed thanks to floating point inaccuracies + 'csch(0)', + 'coth(0)', + 'atanh(1)', + 'asech(0)', + 'acsch(0)', + 'acoth(1)', + ); + +my $zero = cplx(0, 0); + +test_loz( + 'log($zero)', + 'atanh(-1)', + 'acoth(-1)', + ); + +# test the 0**0 + +sub test_ztz { + $test++; + +# push(@script, qq(print "# 0**0\n";)); + push(@script, qq(eval 'cplx(0)**cplx(0)';)); + push(@script, qq(print 'not ' unless (\$@ =~ /zero raised to the/);)); + push(@script, qq( print "ok $test\\n";\n)); +} + +test_ztz; + +# test the bad roots + +sub test_broot { + for my $op (@_) { + $test++; + +# push(@script, qq(print "# root(2, $op)\n";)); + push(@script, qq(eval 'root(2, $op)';)); + push(@script, qq(print 'not ' unless (\$@ =~ /root must be/);)); + push(@script, qq( print "ok $test\\n";\n)); + } +} + +test_broot(qw(-3 -2.1 0 0.99)); + +print "1..$test\n"; +eval join '', @script; +die $@ if $@; + +sub abop { + my ($op) = @_; + + push(@script, qq(print "# $op=\n";)); +} + +sub test { + my ($op, $z, @args) = @_; + my ($baop) = 0; + $test++; + my $i; + $baop = 1 if ($op =~ s/;=$//); + for ($i = 0; $i < @args; $i++) { + $val = value($args[$i]); + push @script, "\$z$i = $val;\n"; + } + if (defined $z) { + $args = "'$op'"; # Really the value + $try = "abs(\$z0 - \$z1) <= $eps ? \$z1 : \$z0"; + push @script, "\$res = $try; "; + push @script, "check($test, $args[0], \$res, \$z$#args, $args);\n"; + } else { + my ($try, $args); + if (@args == 2) { + $try = "$op \$z0"; + $args = "'$args[0]'"; + } else { + $try = ($op =~ /^\w/) ? "$op(\$z0, \$z1)" : "\$z0 $op \$z1"; + $args = "'$args[0]', '$args[1]'"; + } + push @script, "\$res = $try; "; + push @script, "check($test, '$try', \$res, \$z$#args, $args);\n"; + if (@args > 2 and $baop) { # binary assignment ops + $test++; + # check the op= works + push @script, <<EOB; +{ + my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0)); + + my (\$z1r, \$z1i) = ref \$z1 ? \@{\$z1->cartesian} : (\$z1, 0); + + my \$zb = cplx(\$z1r, \$z1i); + + \$za $op= \$zb; + my (\$zbr, \$zbi) = \@{\$zb->cartesian}; + + check($test, '\$z0 $op= \$z1', \$za, \$z$#args, $args); +EOB + $test++; + # check that the rhs has not changed + push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i);); + push @script, qq( print "ok $test\\n";\n); + push @script, "}\n"; + } + } +} + +sub set { + my ($set, $setref, $valref) = @_; + @{$setref} = (); + @{$valref} = (); + my @set = split(/;\s*/, $set); + my @res; + my $i; + for ($i = 0; $i < @set; $i++) { + push(@{$valref}, $set[$i]); + my $val = value($set[$i]); + push @script, "\$s$i = $val;\n"; + push @{$setref}, "\$s$i"; + } +} + +sub value { + local ($_) = @_; + if (/^\s*\((.*),(.*)\)/) { + return "cplx($1,$2)"; + } + elsif (/^\s*\[(.*),(.*)\]/) { + return "cplxe($1,$2)"; + } + elsif (/^\s*'(.*)'/) { + my $ex = $1; + $ex =~ s/\bz\b/$target/g; + $ex =~ s/\br\b/abs($target)/g; + $ex =~ s/\bt\b/arg($target)/g; + $ex =~ s/\ba\b/Re($target)/g; + $ex =~ s/\bb\b/Im($target)/g; + return $ex; + } + elsif (/^\s*"(.*)"/) { + return "\"$1\""; + } + return $_; +} + +sub check { + my ($test, $try, $got, $expected, @z) = @_; + +# print "# @_\n"; + + if ("$got" eq "$expected" + || + ($expected =~ /^-?\d/ && $got == $expected) + || + (abs($got - $expected) < $eps) + ) { + print "ok $test\n"; + } else { + print "not ok $test\n"; + my $args = (@z == 1) ? "z = $z[0]" : "z0 = $z[0], z1 = $z[1]"; + print "# '$try' expected: '$expected' got: '$got' for $args\n"; + } +} + +sub addsq { + my ($z1, $z2) = @_; + return ($z1 + i*$z2) * ($z1 - i*$z2); +} + +sub subsq { + my ($z1, $z2) = @_; + return ($z1 + $z2) * ($z1 - $z2); +} + +__END__ +&+;= +(3,4):(3,4):(6,8) +(-3,4):(3,-4):(0,0) +(3,4):-3:(0,4) +1:(4,2):(5,2) +[2,0]:[2,pi]:(0,0) + +&++ +(2,1):(3,1) + +&-;= +(2,3):(-2,-3) +[2,pi/2]:[2,-(pi)/2] +2:[2,0]:(0,0) +[3,0]:2:(1,0) +3:(4,5):(-1,-5) +(4,5):3:(1,5) +(2,1):(3,5):(-1,-4) + +&-- +(1,2):(0,2) +[2,pi]:[3,pi] + +&*;= +(0,1):(0,1):(-1,0) +(4,5):(1,0):(4,5) +[2,2*pi/3]:(1,0):[2,2*pi/3] +2:(0,1):(0,2) +(0,1):3:(0,3) +(0,1):(4,1):(-1,4) +(2,1):(4,-1):(9,2) + +&/;= +(3,4):(3,4):(1,0) +(4,-5):1:(4,-5) +1:(0,1):(0,-1) +(0,6):(0,2):(3,0) +(9,2):(4,-1):(2,1) +[4,pi]:[2,pi/2]:[2,pi/2] +[2,pi/2]:[4,pi]:[0.5,-(pi)/2] + +&**;= +(2,0):(3,0):(8,0) +(3,0):(2,0):(9,0) +(2,3):(4,0):(-119,-120) +(0,0):(1,0):(0,0) +(0,0):(2,3):(0,0) +(1,0):(0,0):(1,0) +(1,0):(1,0):(1,0) +(1,0):(2,3):(1,0) +(2,3):(0,0):(1,0) +(2,3):(1,0):(2,3) + +&Re +(3,4):3 +(-3,4):-3 +[1,pi/2]:0 + +&Im +(3,4):4 +(3,-4):-4 +[1,pi/2]:1 + +&abs +(3,4):5 +(-3,4):5 + +&arg +[2,0]:0 +[-2,0]:pi + +&~ +(4,5):(4,-5) +(-3,4):(-3,-4) +[2,pi/2]:[2,-(pi)/2] + +&< +(3,4):(1,2):0 +(3,4):(3,2):0 +(3,4):(3,8):1 +(4,4):(5,129):1 + +&== +(3,4):(4,5):0 +(3,4):(3,5):0 +(3,4):(2,4):0 +(3,4):(3,4):1 + +&sqrt +-9:(0,3) +(-100,0):(0,10) +(16,-30):(5,-3) + +&stringify_cartesian +(-100,0):"-100" +(0,1):"i" +(4,-3):"4-3i" +(4,0):"4" +(-4,0):"-4" +(-2,4):"-2+4i" +(-2,-1):"-2-i" + +&stringify_polar +[-1, 0]:"[1,pi]" +[1, pi/3]:"[1,pi/3]" +[6, -2*pi/3]:"[6,-2pi/3]" +[0.5, -9*pi/11]:"[0.5,-9pi/11]" + +{ (4,3); [3,2]; (-3,4); (0,2); [2,1] } + +|'z + ~z':'2*Re(z)' +|'z - ~z':'2*i*Im(z)' +|'z * ~z':'abs(z) * abs(z)' + +{ (0.5, 0); (-0.5, 0); (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] } + +|'(root(z, 4))[1] ** 4':'z' +|'(root(z, 5))[3] ** 5':'z' +|'(root(z, 8))[7] ** 8':'z' +|'abs(z)':'r' +|'acot(z)':'acotan(z)' +|'acsc(z)':'acosec(z)' +|'acsc(z)':'asin(1 / z)' +|'asec(z)':'acos(1 / z)' +|'cbrt(z)':'cbrt(r) * exp(i * t/3)' +|'cos(acos(z))':'z' +|'addsq(cos(z), sin(z))':1 +|'cos(z)':'cosh(i*z)' +|'subsq(cosh(z), sinh(z))':1 +|'cot(acot(z))':'z' +|'cot(z)':'1 / tan(z)' +|'cot(z)':'cotan(z)' +|'csc(acsc(z))':'z' +|'csc(z)':'1 / sin(z)' +|'csc(z)':'cosec(z)' +|'exp(log(z))':'z' +|'exp(z)':'exp(a) * exp(i * b)' +|'ln(z)':'log(z)' +|'log(exp(z))':'z' +|'log(z)':'log(r) + i*t' +|'log10(z)':'log(z) / log(10)' +|'logn(z, 2)':'log(z) / log(2)' +|'logn(z, 3)':'log(z) / log(3)' +|'sec(asec(z))':'z' +|'sec(z)':'1 / cos(z)' +|'sin(asin(z))':'z' +|'sin(i * z)':'i * sinh(z)' +|'sqrt(z) * sqrt(z)':'z' +|'sqrt(z)':'sqrt(r) * exp(i * t/2)' +|'tan(atan(z))':'z' +|'z**z':'exp(z * log(z))' + +{ (1,1); [1,0.5]; (-2, -1); 2; -3; (-1,0.5); (0,0.5); 0.5; (2, 0); (-1, -2) } + +|'cosh(acosh(z))':'z' +|'coth(acoth(z))':'z' +|'coth(z)':'1 / tanh(z)' +|'coth(z)':'cotanh(z)' +|'csch(acsch(z))':'z' +|'csch(z)':'1 / sinh(z)' +|'csch(z)':'cosech(z)' +|'sech(asech(z))':'z' +|'sech(z)':'1 / cosh(z)' +|'sinh(asinh(z))':'z' +|'tanh(atanh(z))':'z' + +{ (0.2,-0.4); [1,0.5]; -1.2; (-1,0.5); 0.5; (1.1, 0) } + +|'acos(cos(z)) ** 2':'z * z' +|'acosh(cosh(z)) ** 2':'z * z' +|'acoth(z)':'acotanh(z)' +|'acoth(z)':'atanh(1 / z)' +|'acsch(z)':'acosech(z)' +|'acsch(z)':'asinh(1 / z)' +|'asech(z)':'acosh(1 / z)' +|'asin(sin(z))':'z' +|'asinh(sinh(z))':'z' +|'atan(tan(z))':'z' +|'atanh(tanh(z))':'z' + +&log +(-2.0,0):( 0.69314718055995, 3.14159265358979) +(-1.0,0):( 0 , 3.14159265358979) +(-0.5,0):( -0.69314718055995, 3.14159265358979) +( 0.5,0):( -0.69314718055995, 0 ) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 0.69314718055995, 0 ) + +&log +( 2, 3):( 1.28247467873077, 0.98279372324733) +(-2, 3):( 1.28247467873077, 2.15879893034246) +(-2,-3):( 1.28247467873077, -2.15879893034246) +( 2,-3):( 1.28247467873077, -0.98279372324733) + +&sin +(-2.0,0):( -0.90929742682568, 0 ) +(-1.0,0):( -0.84147098480790, 0 ) +(-0.5,0):( -0.47942553860420, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.47942553860420, 0 ) +( 1.0,0):( 0.84147098480790, 0 ) +( 2.0,0):( 0.90929742682568, 0 ) + +&sin +( 2, 3):( 9.15449914691143, -4.16890695996656) +(-2, 3):( -9.15449914691143, -4.16890695996656) +(-2,-3):( -9.15449914691143, 4.16890695996656) +( 2,-3):( 9.15449914691143, 4.16890695996656) + +&cos +(-2.0,0):( -0.41614683654714, 0 ) +(-1.0,0):( 0.54030230586814, 0 ) +(-0.5,0):( 0.87758256189037, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 0.87758256189037, 0 ) +( 1.0,0):( 0.54030230586814, 0 ) +( 2.0,0):( -0.41614683654714, 0 ) + +&cos +( 2, 3):( -4.18962569096881, -9.10922789375534) +(-2, 3):( -4.18962569096881, 9.10922789375534) +(-2,-3):( -4.18962569096881, -9.10922789375534) +( 2,-3):( -4.18962569096881, 9.10922789375534) + +&tan +(-2.0,0):( 2.18503986326152, 0 ) +(-1.0,0):( -1.55740772465490, 0 ) +(-0.5,0):( -0.54630248984379, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.54630248984379, 0 ) +( 1.0,0):( 1.55740772465490, 0 ) +( 2.0,0):( -2.18503986326152, 0 ) + +&tan +( 2, 3):( -0.00376402564150, 1.00323862735361) +(-2, 3):( 0.00376402564150, 1.00323862735361) +(-2,-3):( 0.00376402564150, -1.00323862735361) +( 2,-3):( -0.00376402564150, -1.00323862735361) + +&sec +(-2.0,0):( -2.40299796172238, 0 ) +(-1.0,0):( 1.85081571768093, 0 ) +(-0.5,0):( 1.13949392732455, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 1.13949392732455, 0 ) +( 1.0,0):( 1.85081571768093, 0 ) +( 2.0,0):( -2.40299796172238, 0 ) + +&sec +( 2, 3):( -0.04167496441114, 0.09061113719624) +(-2, 3):( -0.04167496441114, -0.09061113719624) +(-2,-3):( -0.04167496441114, 0.09061113719624) +( 2,-3):( -0.04167496441114, -0.09061113719624) + +&csc +(-2.0,0):( -1.09975017029462, 0 ) +(-1.0,0):( -1.18839510577812, 0 ) +(-0.5,0):( -2.08582964293349, 0 ) +( 0.5,0):( 2.08582964293349, 0 ) +( 1.0,0):( 1.18839510577812, 0 ) +( 2.0,0):( 1.09975017029462, 0 ) + +&csc +( 2, 3):( 0.09047320975321, 0.04120098628857) +(-2, 3):( -0.09047320975321, 0.04120098628857) +(-2,-3):( -0.09047320975321, -0.04120098628857) +( 2,-3):( 0.09047320975321, -0.04120098628857) + +&cot +(-2.0,0):( 0.45765755436029, 0 ) +(-1.0,0):( -0.64209261593433, 0 ) +(-0.5,0):( -1.83048772171245, 0 ) +( 0.5,0):( 1.83048772171245, 0 ) +( 1.0,0):( 0.64209261593433, 0 ) +( 2.0,0):( -0.45765755436029, 0 ) + +&cot +( 2, 3):( -0.00373971037634, -0.99675779656936) +(-2, 3):( 0.00373971037634, -0.99675779656936) +(-2,-3):( 0.00373971037634, 0.99675779656936) +( 2,-3):( -0.00373971037634, 0.99675779656936) + +&asin +(-2.0,0):( -1.57079632679490, 1.31695789692482) +(-1.0,0):( -1.57079632679490, 0 ) +(-0.5,0):( -0.52359877559830, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.52359877559830, 0 ) +( 1.0,0):( 1.57079632679490, 0 ) +( 2.0,0):( 1.57079632679490, -1.31695789692482) + +&asin +( 2, 3):( 0.57065278432110, 1.98338702991654) +(-2, 3):( -0.57065278432110, 1.98338702991654) +(-2,-3):( -0.57065278432110, -1.98338702991654) +( 2,-3):( 0.57065278432110, -1.98338702991654) + +&acos +(-2.0,0):( 3.14159265358979, -1.31695789692482) +(-1.0,0):( 3.14159265358979, 0 ) +(-0.5,0):( 2.09439510239320, 0 ) +( 0.0,0):( 1.57079632679490, 0 ) +( 0.5,0):( 1.04719755119660, 0 ) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 0 , 1.31695789692482) + +&acos +( 2, 3):( 1.00014354247380, -1.98338702991654) +(-2, 3):( 2.14144911111600, -1.98338702991654) +(-2,-3):( 2.14144911111600, 1.98338702991654) +( 2,-3):( 1.00014354247380, 1.98338702991654) + +&atan +(-2.0,0):( -1.10714871779409, 0 ) +(-1.0,0):( -0.78539816339745, 0 ) +(-0.5,0):( -0.46364760900081, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.46364760900081, 0 ) +( 1.0,0):( 0.78539816339745, 0 ) +( 2.0,0):( 1.10714871779409, 0 ) + +&atan +( 2, 3):( 1.40992104959658, 0.22907268296854) +(-2, 3):( -1.40992104959658, 0.22907268296854) +(-2,-3):( -1.40992104959658, -0.22907268296854) +( 2,-3):( 1.40992104959658, -0.22907268296854) + +&asec +(-2.0,0):( 2.09439510239320, 0 ) +(-1.0,0):( 3.14159265358979, 0 ) +(-0.5,0):( 3.14159265358979, -1.31695789692482) +( 0.5,0):( 0 , 1.31695789692482) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 1.04719755119660, 0 ) + +&asec +( 2, 3):( 1.42041072246703, 0.23133469857397) +(-2, 3):( 1.72118193112276, 0.23133469857397) +(-2,-3):( 1.72118193112276, -0.23133469857397) +( 2,-3):( 1.42041072246703, -0.23133469857397) + +&acsc +(-2.0,0):( -0.52359877559830, 0 ) +(-1.0,0):( -1.57079632679490, 0 ) +(-0.5,0):( -1.57079632679490, 1.31695789692482) +( 0.5,0):( 1.57079632679490, -1.31695789692482) +( 1.0,0):( 1.57079632679490, 0 ) +( 2.0,0):( 0.52359877559830, 0 ) + +&acsc +( 2, 3):( 0.15038560432786, -0.23133469857397) +(-2, 3):( -0.15038560432786, -0.23133469857397) +(-2,-3):( -0.15038560432786, 0.23133469857397) +( 2,-3):( 0.15038560432786, 0.23133469857397) + +&acot +(-2.0,0):( -0.46364760900081, 0 ) +(-1.0,0):( -0.78539816339745, 0 ) +(-0.5,0):( -1.10714871779409, 0 ) +( 0.5,0):( 1.10714871779409, 0 ) +( 1.0,0):( 0.78539816339745, 0 ) +( 2.0,0):( 0.46364760900081, 0 ) + +&acot +( 2, 3):( 0.16087527719832, -0.22907268296854) +(-2, 3):( -0.16087527719832, -0.22907268296854) +(-2,-3):( -0.16087527719832, 0.22907268296854) +( 2,-3):( 0.16087527719832, 0.22907268296854) + +&sinh +(-2.0,0):( -3.62686040784702, 0 ) +(-1.0,0):( -1.17520119364380, 0 ) +(-0.5,0):( -0.52109530549375, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.52109530549375, 0 ) +( 1.0,0):( 1.17520119364380, 0 ) +( 2.0,0):( 3.62686040784702, 0 ) + +&sinh +( 2, 3):( -3.59056458998578, 0.53092108624852) +(-2, 3):( 3.59056458998578, 0.53092108624852) +(-2,-3):( 3.59056458998578, -0.53092108624852) +( 2,-3):( -3.59056458998578, -0.53092108624852) + +&cosh +(-2.0,0):( 3.76219569108363, 0 ) +(-1.0,0):( 1.54308063481524, 0 ) +(-0.5,0):( 1.12762596520638, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 1.12762596520638, 0 ) +( 1.0,0):( 1.54308063481524, 0 ) +( 2.0,0):( 3.76219569108363, 0 ) + +&cosh +( 2, 3):( -3.72454550491532, 0.51182256998738) +(-2, 3):( -3.72454550491532, -0.51182256998738) +(-2,-3):( -3.72454550491532, 0.51182256998738) +( 2,-3):( -3.72454550491532, -0.51182256998738) + +&tanh +(-2.0,0):( -0.96402758007582, 0 ) +(-1.0,0):( -0.76159415595576, 0 ) +(-0.5,0):( -0.46211715726001, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.46211715726001, 0 ) +( 1.0,0):( 0.76159415595576, 0 ) +( 2.0,0):( 0.96402758007582, 0 ) + +&tanh +( 2, 3):( 0.96538587902213, -0.00988437503832) +(-2, 3):( -0.96538587902213, -0.00988437503832) +(-2,-3):( -0.96538587902213, 0.00988437503832) +( 2,-3):( 0.96538587902213, 0.00988437503832) + +&sech +(-2.0,0):( 0.26580222883408, 0 ) +(-1.0,0):( 0.64805427366389, 0 ) +(-0.5,0):( 0.88681888397007, 0 ) +( 0.0,0):( 1 , 0 ) +( 0.5,0):( 0.88681888397007, 0 ) +( 1.0,0):( 0.64805427366389, 0 ) +( 2.0,0):( 0.26580222883408, 0 ) + +&sech +( 2, 3):( -0.26351297515839, -0.03621163655877) +(-2, 3):( -0.26351297515839, 0.03621163655877) +(-2,-3):( -0.26351297515839, -0.03621163655877) +( 2,-3):( -0.26351297515839, 0.03621163655877) + +&csch +(-2.0,0):( -0.27572056477178, 0 ) +(-1.0,0):( -0.85091812823932, 0 ) +(-0.5,0):( -1.91903475133494, 0 ) +( 0.5,0):( 1.91903475133494, 0 ) +( 1.0,0):( 0.85091812823932, 0 ) +( 2.0,0):( 0.27572056477178, 0 ) + +&csch +( 2, 3):( -0.27254866146294, -0.04030057885689) +(-2, 3):( 0.27254866146294, -0.04030057885689) +(-2,-3):( 0.27254866146294, 0.04030057885689) +( 2,-3):( -0.27254866146294, 0.04030057885689) + +&coth +(-2.0,0):( -1.03731472072755, 0 ) +(-1.0,0):( -1.31303528549933, 0 ) +(-0.5,0):( -2.16395341373865, 0 ) +( 0.5,0):( 2.16395341373865, 0 ) +( 1.0,0):( 1.31303528549933, 0 ) +( 2.0,0):( 1.03731472072755, 0 ) + +&coth +( 2, 3):( 1.03574663776500, 0.01060478347034) +(-2, 3):( -1.03574663776500, 0.01060478347034) +(-2,-3):( -1.03574663776500, -0.01060478347034) +( 2,-3):( 1.03574663776500, -0.01060478347034) + +&asinh +(-2.0,0):( -1.44363547517881, 0 ) +(-1.0,0):( -0.88137358701954, 0 ) +(-0.5,0):( -0.48121182505960, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.48121182505960, 0 ) +( 1.0,0):( 0.88137358701954, 0 ) +( 2.0,0):( 1.44363547517881, 0 ) + +&asinh +( 2, 3):( 1.96863792579310, 0.96465850440760) +(-2, 3):( -1.96863792579310, 0.96465850440761) +(-2,-3):( -1.96863792579310, -0.96465850440761) +( 2,-3):( 1.96863792579310, -0.96465850440760) + +&acosh +(-2.0,0):( -1.31695789692482, 3.14159265358979) +(-1.0,0):( 0, 3.14159265358979) +(-0.5,0):( 0, 2.09439510239320) +( 0.0,0):( 0, 1.57079632679490) +( 0.5,0):( 0, 1.04719755119660) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 1.31695789692482, 0 ) + +&acosh +( 2, 3):( 1.98338702991654, 1.00014354247380) +(-2, 3):( -1.98338702991653, -2.14144911111600) +(-2,-3):( -1.98338702991653, 2.14144911111600) +( 2,-3):( 1.98338702991654, -1.00014354247380) + +&atanh +(-2.0,0):( -0.54930614433405, 1.57079632679490) +(-0.5,0):( -0.54930614433405, 0 ) +( 0.0,0):( 0 , 0 ) +( 0.5,0):( 0.54930614433405, 0 ) +( 2.0,0):( 0.54930614433405, 1.57079632679490) + +&atanh +( 2, 3):( 0.14694666622553, 1.33897252229449) +(-2, 3):( -0.14694666622553, 1.33897252229449) +(-2,-3):( -0.14694666622553, -1.33897252229449) +( 2,-3):( 0.14694666622553, -1.33897252229449) + +&asech +(-2.0,0):( 0 , 2.09439510239320) +(-1.0,0):( 0 , 3.14159265358979) +(-0.5,0):( -1.31695789692482, 3.14159265358979) +( 0.5,0):( 1.31695789692482, 0 ) +( 1.0,0):( 0 , 0 ) +( 2.0,0):( 0 , 1.04719755119660) + +&asech +( 2, 3):( 0.23133469857397, -1.42041072246703) +(-2, 3):( -0.23133469857397, 1.72118193112276) +(-2,-3):( -0.23133469857397, -1.72118193112276) +( 2,-3):( 0.23133469857397, 1.42041072246703) + +&acsch +(-2.0,0):( -0.48121182505960, 0 ) +(-1.0,0):( -0.88137358701954, 0 ) +(-0.5,0):( -1.44363547517881, 0 ) +( 0.5,0):( 1.44363547517881, 0 ) +( 1.0,0):( 0.88137358701954, 0 ) +( 2.0,0):( 0.48121182505960, 0 ) + +&acsch +( 2, 3):( 0.15735549884499, -0.22996290237721) +(-2, 3):( -0.15735549884499, -0.22996290237721) +(-2,-3):( -0.15735549884499, 0.22996290237721) +( 2,-3):( 0.15735549884499, 0.22996290237721) + +&acoth +(-2.0,0):( -0.54930614433405, 0 ) +(-0.5,0):( -0.54930614433405, 1.57079632679490) +( 0.5,0):( 0.54930614433405, 1.57079632679490) +( 2.0,0):( 0.54930614433405, 0 ) + +&acoth +( 2, 3):( 0.14694666622553, -0.23182380450040) +(-2, 3):( -0.14694666622553, -0.23182380450040) +(-2,-3):( -0.14694666622553, 0.23182380450040) +( 2,-3):( 0.14694666622553, 0.23182380450040) + +# eof + diff --git a/gnu/usr.bin/perl/t/lib/dosglob.t b/gnu/usr.bin/perl/t/lib/dosglob.t new file mode 100644 index 00000000000..7398a140652 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/dosglob.t @@ -0,0 +1,94 @@ +#!./perl + +# +# test glob() in File::DosGlob +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..9\n"; + +# override it in main:: +use File::DosGlob 'glob'; + +# test if $_ takes as the default +$_ = "lib/a*.t"; +my @r = glob; +print "not " if $_ ne 'lib/a*.t'; +print "ok 1\n"; +# we should have at least abbrev.t, anydbm.t, autoloader.t +print "# |@r|\nnot " if @r < 3; +print "ok 2\n"; + +# check if <*/*> works +@r = <*/a*.t>; +# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t +print "not " if @r < 9; +print "ok 3\n"; +my $r = scalar @r; + +# check if scalar context works +@r = (); +while (defined($_ = <*/a*.t>)) { + print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 4\n"; + +# check if array context works +@r = (); +for (<*/a*.t>) { + print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 5\n"; + +# test if implicit assign to $_ in while() works +@r = (); +while (<*/a*.t>) { + print "# $_\n"; + push @r, $_; +} +print "not " if @r != $r; +print "ok 6\n"; + +# test if explicit glob() gets assign magic too +my @s = (); +while (glob '*/a*.t') { + print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 7\n"; + +# how about in a different package, like? +package Foo; +use File::DosGlob 'glob'; +@s = (); +while (glob '*/a*.t') { + print "# $_\n"; + push @s, $_; +} +print "not " if "@r" ne "@s"; +print "ok 8\n"; + +# test if different glob ops maintain independent contexts +@s = (); +while (<*/a*.t>) { + my $i = 0; + print "# $_ <"; + push @s, $_; + while (<*/b*.t>) { + print " $_"; + $i++; + } + print " >\n"; +} +print "not " if "@r" ne "@s"; +print "ok 9\n"; + diff --git a/gnu/usr.bin/perl/t/lib/env.t b/gnu/usr.bin/perl/t/lib/env.t new file mode 100644 index 00000000000..5a8220778aa --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/env.t @@ -0,0 +1,18 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +BEGIN { + $ENV{FOO} = "foo"; +} + +use Env qw(FOO); + +$FOO .= "/bar"; + +print "1..1\n"; +print "not " if $FOO ne 'foo/bar'; +print "ok 1\n"; diff --git a/gnu/usr.bin/perl/t/lib/filecache.t b/gnu/usr.bin/perl/t/lib/filecache.t new file mode 100644 index 00000000000..a97fdd532c6 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/filecache.t @@ -0,0 +1,25 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..1\n"; + +use FileCache; + +# This is really not a complete test as I don't bother to open enough +# files to make real swapping of open filedescriptor happen. + +$path = "foo"; +cacheout $path; + +print $path "\n"; + +close $path; + +print "not " unless -f $path; +print "ok 1\n"; + +unlink $path; diff --git a/gnu/usr.bin/perl/t/lib/filecopy.t b/gnu/usr.bin/perl/t/lib/filecopy.t new file mode 100644 index 00000000000..b718215a1e4 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/filecopy.t @@ -0,0 +1,88 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..11\n"; + +$| = 1; + +use File::Copy; + +# First we create a file +open(F, ">file-$$") or die; +print F "ok 3\n"; +close F; + +copy "file-$$", "copy-$$"; + +open(F, "copy-$$") or die; +$foo = <F>; +close(F); + +print "not " if -s "file-$$" != -s "copy-$$"; +print "ok 1\n"; + +print "not " unless $foo eq "ok 3\n"; +print "ok 2\n"; + +copy "copy-$$", \*STDOUT; +unlink "copy-$$" or die "unlink: $!"; + +open(F,"file-$$"); +copy(*F, "copy-$$"); +open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 4\n"; +unlink "copy-$$" or die "unlink: $!"; +open(F,"file-$$"); +copy(\*F, "copy-$$"); +close(F) or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!"; +print "not " unless $foo eq "ok 3\n"; +print "ok 5\n"; +unlink "copy-$$" or die "unlink: $!"; + +require IO::File; +$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close or die "close: $!"; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 6\n"; +unlink "copy-$$" or die "unlink: $!"; +require FileHandle; +my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!"; +binmode $fh or die; +copy("file-$$",$fh); +$fh->close; +open(R, "copy-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 7\n"; +unlink "file-$$" or die "unlink: $!"; + +print "# moved missing file.\nnot " if move("file-$$", "copy-$$"); +print "# target disappeared.\nnot " if not -e "copy-$$"; +print "ok 8\n"; + +move "copy-$$", "file-$$" or print "# move did not succeed.\n"; +print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$"; +open(R, "file-$$") or die; $foo = <R>; close(R); +print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n"; +print "ok 9\n"; + +copy "file-$$", "lib"; +open(R, "lib/file-$$") or die; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n"; +print "ok 10\n"; +unlink "lib/file-$$" or die "unlink: $!"; + +move "file-$$", "lib"; +open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R); +print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; +print "ok 11\n"; +unlink "lib/file-$$" or die "unlink: $!"; + diff --git a/gnu/usr.bin/perl/t/lib/filefind.t b/gnu/usr.bin/perl/t/lib/filefind.t new file mode 100644 index 00000000000..21e29a2d7fb --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/filefind.t @@ -0,0 +1,13 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..1\n"; + +use File::Find; + +# hope we will eventually find ourself +find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, "."); diff --git a/gnu/usr.bin/perl/t/lib/filepath.t b/gnu/usr.bin/perl/t/lib/filepath.t new file mode 100644 index 00000000000..c3bf4a44799 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/filepath.t @@ -0,0 +1,28 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use File::Path; +use strict; + +my $count = 0; +$^W = 1; + +print "1..4\n"; + +# first check for stupid permissions second for full, so we clean up +# behind ourselves +for my $perm (0111,0777) { + mkpath("foo/bar"); + chmod $perm, "foo", "foo/bar"; + + print "not " unless -d "foo" && -d "foo/bar"; + print "ok ", ++$count, "\n"; + + rmtree("foo"); + print "not " if -e "foo"; + print "ok ", ++$count, "\n"; +} diff --git a/gnu/usr.bin/perl/t/lib/findbin.t b/gnu/usr.bin/perl/t/lib/findbin.t new file mode 100644 index 00000000000..3e742f9a4f7 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/findbin.t @@ -0,0 +1,13 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..1\n"; + +use FindBin qw($Bin); + +print "not " unless $Bin =~ m,t[/.]lib\]?$,; +print "ok 1\n"; diff --git a/gnu/usr.bin/perl/t/lib/getopt.t b/gnu/usr.bin/perl/t/lib/getopt.t new file mode 100644 index 00000000000..fb70f10aae8 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/getopt.t @@ -0,0 +1,73 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..11\n"; + +use Getopt::Std; + +# First we test the getopt function +@ARGV = qw(-xo -f foo -y file); +getopt('f'); + +print "not " if "@ARGV" ne 'file'; +print "ok 1\n"; + +print "not " unless $opt_x && $opt_o && opt_y; +print "ok 2\n"; + +print "not " unless $opt_f eq 'foo'; +print "ok 3\n"; + + +# Then we try the getopts +$opt_o = $opt_i = $opt_f = undef; +@ARGV = qw(-foi -i file); +getopts('oif:') or print "not "; +print "ok 4\n"; + +print "not " unless "@ARGV" eq 'file'; +print "ok 5\n"; + +print "not " unless $opt_i and $opt_f eq 'oi'; +print "ok 6\n"; + +print "not " if $opt_o; +print "ok 7\n"; + +# Try illegal options, but avoid printing of the error message + +open(STDERR, ">stderr") || die; + +@ARGV = qw(-h help); + +!getopts("xf:y") or print "not "; +print "ok 8\n"; + + +# Then try the Getopt::Long module + +use Getopt::Long; + +@ARGV = qw(--help --file foo --foo --nobar --num=5 -- file); + +GetOptions( + 'help' => \$HELP, + 'file:s' => \$FILE, + 'foo!' => \$FOO, + 'bar!' => \$BAR, + 'num:i' => \$NO, +) || print "not "; +print "ok 9\n"; + +print "not " unless $HELP && $FOO && !$BAR && $FILE eq 'foo' && $NO == 5; +print "ok 10\n"; + +print "not " unless "@ARGV" eq "file"; +print "ok 11\n"; + +close STDERR; +unlink "stderr"; diff --git a/gnu/usr.bin/perl/t/lib/hostname.t b/gnu/usr.bin/perl/t/lib/hostname.t new file mode 100644 index 00000000000..e4ac36521c7 --- /dev/null +++ b/gnu/usr.bin/perl/t/lib/hostname.t @@ -0,0 +1,19 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Sys::Hostname; + +eval { + $host = hostname; +}; + +if ($@) { + print "1..0\n" if $@ =~ /Cannot get host name/; +} else { + print "1..1\n"; + print "ok 1\n"; +} |
