develooper Front page | perl.perl5.porters | Postings from February 2000

[PATCH 5.5.640] add gethostname() (was Re: fixing Sys::Hostname)

Thread Next
From:
Greg Bacon
Date:
February 7, 2000 13:56
Subject:
[PATCH 5.5.640] add gethostname() (was Re: fixing Sys::Hostname)
Message ID:
200002072203.QAA20598@ruby.itsc.uah.edu
In message <6923.949758404@chthon>,
    Tom Christiansen writes:

: The latest changes to Sys::Hostname's (no, that's not the ::s module
: :-) hostname() function need to be addressed.  Why?  Because they
: by default needlessly pull in a ziggabyte of POSIX material just
: to get at uname(). The performance hit is dramatic and permanent.

How's this?  In addition to adding a gethostname() operator, it updates
Sys::Hostname to make use of the new operator.  It needs PERL_OBJECT
support and a perldelta patch if Sarathy likes it.  With the exception
of the known DB_File issue, this perl builds and passes all tests.

Don't forget to make regen_headers.

diff -ruN perl5.5.640.dist/embed.h perl5.5.640/embed.h
--- perl5.5.640.dist/embed.h	Wed Feb  2 00:53:46 2000
+++ perl5.5.640/embed.h	Mon Feb  7 15:09:26 2000
@@ -1251,6 +1251,7 @@
 #define pp_ggrnam		Perl_pp_ggrnam
 #define pp_ghbyaddr		Perl_pp_ghbyaddr
 #define pp_ghbyname		Perl_pp_ghbyname
+#define pp_ghname		Perl_pp_ghname
 #define pp_ghostent		Perl_pp_ghostent
 #define pp_glob			Perl_pp_glob
 #define pp_gmtime		Perl_pp_gmtime
@@ -2663,6 +2664,7 @@
 #define pp_ggrnam()		Perl_pp_ggrnam(aTHX)
 #define pp_ghbyaddr()		Perl_pp_ghbyaddr(aTHX)
 #define pp_ghbyname()		Perl_pp_ghbyname(aTHX)
+#define pp_ghname()		Perl_pp_ghname(aTHX)
 #define pp_ghostent()		Perl_pp_ghostent(aTHX)
 #define pp_glob()		Perl_pp_glob(aTHX)
 #define pp_gmtime()		Perl_pp_gmtime(aTHX)
@@ -5179,6 +5181,8 @@
 #define pp_ghbyaddr		Perl_pp_ghbyaddr
 #define Perl_pp_ghbyname	CPerlObj::Perl_pp_ghbyname
 #define pp_ghbyname		Perl_pp_ghbyname
+#define Perl_pp_ghname		CPerlObj::Perl_pp_ghname
+#define pp_ghname		Perl_pp_ghname
 #define Perl_pp_ghostent	CPerlObj::Perl_pp_ghostent
 #define pp_ghostent		Perl_pp_ghostent
 #define Perl_pp_glob		CPerlObj::Perl_pp_glob
diff -ruN perl5.5.640.dist/ext/Opcode/Opcode.pm perl5.5.640/ext/Opcode/Opcode.pm
--- perl5.5.640.dist/ext/Opcode/Opcode.pm	Sun Jan 23 04:34:30 2000
+++ perl5.5.640/ext/Opcode/Opcode.pm	Mon Feb  7 15:08:15 2000
@@ -458,13 +458,13 @@
 
 =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
+    ghbyname ghbyaddr ghostent shostent ehostent ghname -- 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
+    gpwnam gpwuid gpwent spwent epwent getlogin         -- users
+    ggrnam ggrgid ggrent sgrent egrent                  -- groups
 
 =item :browse
 
diff -ruN perl5.5.640.dist/iperlsys.h perl5.5.640/iperlsys.h
--- perl5.5.640.dist/iperlsys.h	Thu Jan 27 16:53:27 2000
+++ perl5.5.640/iperlsys.h	Mon Feb  7 14:50:44 2000
@@ -1099,6 +1099,8 @@
 	(*PL_Proc->pGetgid)(PL_Proc)
 #define PerlProc_getegid()						\
 	(*PL_Proc->pGetegid)(PL_Proc)
+#define PerlProc_gethostname()						\
+	(*PL_Proc->pGethostname)(PL_Proc)
 #define PerlProc_getlogin()						\
 	(*PL_Proc->pGetlogin)(PL_Proc)
 #define PerlProc_kill(i, a)						\
@@ -1163,6 +1165,8 @@
 #define PerlProc_geteuid()	geteuid()
 #define PerlProc_getgid()	getgid()
 #define PerlProc_getegid()	getegid()
+#define PerlProc_gethostname(s, n)					\
+				gethostname((s), (n))
 #define PerlProc_getlogin()	getlogin()
 #define PerlProc_kill(i, a)	kill((i), (a))
 #define PerlProc_killpg(i, a)	killpg((i), (a))
@@ -1345,8 +1349,6 @@
 	(*PL_Sock->pGethostbyname)(PL_Sock, n)
 #define PerlSock_gethostent()						\
 	(*PL_Sock->pGethostent)(PL_Sock)
-#define PerlSock_gethostname(n, l)					\
-	(*PL_Sock->pGethostname)(PL_Sock, n, l)
 #define PerlSock_getnetbyaddr(n, t)					\
 	(*PL_Sock->pGetnetbyaddr)(PL_Sock, n, t)
 #define PerlSock_getnetbyname(c)					\
diff -ruN perl5.5.640.dist/keywords.pl perl5.5.640/keywords.pl
--- perl5.5.640.dist/keywords.pl	Wed Jan 26 12:56:46 2000
+++ perl5.5.640/keywords.pl	Mon Feb  7 12:52:05 2000
@@ -105,6 +105,7 @@
 gethostbyaddr
 gethostbyname
 gethostent
+gethostname
 getlogin
 getnetbyaddr
 getnetbyname
diff -ruN perl5.5.640.dist/lib/Sys/Hostname.pm perl5.5.640/lib/Sys/Hostname.pm
--- perl5.5.640.dist/lib/Sys/Hostname.pm	Sun Jan 23 02:46:22 2000
+++ perl5.5.640/lib/Sys/Hostname.pm	Mon Feb  7 15:53:28 2000
@@ -17,7 +17,7 @@
 =head1 DESCRIPTION
 
 Attempts several methods of getting the system hostname and
-then caches the result.  It tries C<syscall(SYS_gethostname)>,
+then caches the result.  It tries gethostname(),
 C<`hostname`>, C<`uname -n`>, and the file F</com/host>.
 If all that fails it C<croak>s.
 
@@ -34,6 +34,10 @@
 sub hostname {
 
   # method 1 - we already know it
+  return $host if defined $host;
+
+  # method 1a - ask the system
+  eval { local $SIG{__DIE__}; $host = gethostname };
   return $host if defined $host;
 
   if ($^O eq 'VMS') {
diff -ruN perl5.5.640.dist/op.c perl5.5.640/op.c
--- perl5.5.640.dist/op.c	Tue Feb  1 14:29:47 2000
+++ perl5.5.640/op.c	Mon Feb  7 15:31:43 2000
@@ -1114,6 +1114,7 @@
     case OP_GGRNAM:
     case OP_GGRGID:
     case OP_GETLOGIN:
+    case OP_GHNAME:
       func_ops:
 	if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 	    useless = PL_op_desc[o->op_type];
diff -ruN perl5.5.640.dist/opcode.h perl5.5.640/opcode.h
--- perl5.5.640.dist/opcode.h	Thu Jan 27 16:53:27 2000
+++ perl5.5.640/opcode.h	Mon Feb  7 15:09:25 2000
@@ -361,6 +361,7 @@
 	"sgrent",
 	"egrent",
 	"getlogin",
+	"ghname",
 	"syscall",
 	"lock",
 	"threadsv",
@@ -719,6 +720,7 @@
 	"setgrent",
 	"endgrent",
 	"getlogin",
+	"gethostname",
 	"syscall",
 	"lock",
 	"per-thread value",
@@ -1082,6 +1084,7 @@
 	MEMBER_TO_FPTR(Perl_pp_sgrent),
 	MEMBER_TO_FPTR(Perl_pp_egrent),
 	MEMBER_TO_FPTR(Perl_pp_getlogin),
+	MEMBER_TO_FPTR(Perl_pp_ghname),
 	MEMBER_TO_FPTR(Perl_pp_syscall),
 	MEMBER_TO_FPTR(Perl_pp_lock),
 	MEMBER_TO_FPTR(Perl_pp_threadsv),
@@ -1440,6 +1443,7 @@
 	MEMBER_TO_FPTR(Perl_ck_null),	/* sgrent */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* egrent */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* getlogin */
+	MEMBER_TO_FPTR(Perl_ck_null),	/* ghname */
 	MEMBER_TO_FPTR(Perl_ck_fun),	/* syscall */
 	MEMBER_TO_FPTR(Perl_ck_rfun),	/* lock */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* threadsv */
@@ -1798,6 +1802,7 @@
 	0x00000014,	/* sgrent */
 	0x00000014,	/* egrent */
 	0x0000000c,	/* getlogin */
+	0x0000000c,	/* ghname */
 	0x0004281d,	/* syscall */
 	0x00003604,	/* lock */
 	0x00000044,	/* threadsv */
diff -ruN perl5.5.640.dist/opcode.pl perl5.5.640/opcode.pl
--- perl5.5.640.dist/opcode.pl	Wed Jan 12 15:03:56 2000
+++ perl5.5.640/opcode.pl	Mon Feb  7 15:07:26 2000
@@ -327,7 +327,8 @@
 #	backtick glob warn die not OK (not always setting)
 #	warn not OK (RETPUSHYES)
 #	open fileno getc sysread syswrite ioctl accept shutdown
-#	 ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF)
+#	 ftsize(etc) readlink telldir fork alarm getlogin
+#        gethostname not OK (RETPUSHUNDEF)
 #	umask select not OK (XPUSHs(&PL_sv_undef);)
 #	fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC"))
 #	sselect shm* sem* msg* syscall - unknown whether they are safe
@@ -811,6 +812,7 @@
 sgrent		setgrent		ck_null		is0	
 egrent		endgrent		ck_null		is0	
 getlogin	getlogin		ck_null		st0	
+ghname		gethostname		ck_null		st0	
 
 # Miscellaneous.
 
diff -ruN perl5.5.640.dist/opnames.h perl5.5.640/opnames.h
--- perl5.5.640.dist/opnames.h	Thu Jan 27 16:53:27 2000
+++ perl5.5.640/opnames.h	Mon Feb  7 15:09:25 2000
@@ -350,13 +350,14 @@
 	OP_SGRENT,	/* 343 */
 	OP_EGRENT,	/* 344 */
 	OP_GETLOGIN,	/* 345 */
-	OP_SYSCALL,	/* 346 */
-	OP_LOCK,	/* 347 */
-	OP_THREADSV,	/* 348 */
-	OP_SETSTATE,	/* 349 */
-	OP_METHOD_NAMED,/* 350 */
+	OP_GHNAME,	/* 346 */
+	OP_SYSCALL,	/* 347 */
+	OP_LOCK,	/* 348 */
+	OP_THREADSV,	/* 349 */
+	OP_SETSTATE,	/* 350 */
+	OP_METHOD_NAMED,/* 351 */
 	OP_max		
 } opcode;
 
-#define MAXO 351
+#define MAXO 352
 
diff -ruN perl5.5.640.dist/pod/perlfunc.pod perl5.5.640/pod/perlfunc.pod
--- perl5.5.640.dist/pod/perlfunc.pod	Wed Feb  2 02:14:32 2000
+++ perl5.5.640/pod/perlfunc.pod	Mon Feb  7 15:30:27 2000
@@ -188,7 +188,7 @@
 =item Fetching network info
 
 C<endprotoent>, C<endservent>, C<gethostbyaddr>, C<gethostbyname>,
-C<gethostent>, C<getnetbyaddr>, C<getnetbyname>, C<getnetent>,
+C<gethostent>, C<gethostname>, C<getnetbyaddr>, C<getnetbyname>, C<getnetent>,
 C<getprotobyname>, C<getprotobynumber>, C<getprotoent>,
 C<getservbyname>, C<getservbyport>, C<getservent>, C<sethostent>,
 C<setnetent>, C<setprotoent>, C<setservent>
@@ -225,7 +225,7 @@
 C<dbmclose>, C<dbmopen>, C<dump>, C<endgrent>, C<endhostent>,
 C<endnetent>, C<endprotoent>, C<endpwent>, C<endservent>, C<exec>,
 C<fcntl>, C<flock>, C<fork>, C<getgrent>, C<getgrgid>, C<gethostent>,
-C<getlogin>, C<getnetbyaddr>, C<getnetbyname>, C<getnetent>,
+C<gethostname>, C<getlogin>, C<getnetbyaddr>, C<getnetbyname>, C<getnetent>,
 C<getppid>, C<getprgp>, C<getpriority>, C<getprotobynumber>,
 C<getprotoent>, C<getpwent>, C<getpwnam>, C<getpwuid>,
 C<getservbyport>, C<getservent>, C<getsockopt>, C<glob>, C<ioctl>,
@@ -1705,6 +1705,14 @@
 systems purporting POSIX compliance.  See also the C<Term::ReadKey>
 module from your nearest CPAN site; details on CPAN can be found on
 L<perlmodlib/CPAN>.
+
+=item gethostname
+
+Implements the C library function of the same name.  If C<gethostname>
+is not available on your system, use C<Sys::Hostname> (see
+L<Sys::Hostname>).
+
+    $hostname = gethostname || `hostname` || "beatsme";
 
 =item getlogin
 
diff -ruN perl5.5.640.dist/pp.sym perl5.5.640/pp.sym
--- perl5.5.640.dist/pp.sym	Sun Jan  2 15:12:55 2000
+++ perl5.5.640/pp.sym	Mon Feb  7 15:09:25 2000
@@ -382,6 +382,7 @@
 Perl_pp_sgrent
 Perl_pp_egrent
 Perl_pp_getlogin
+Perl_pp_ghname
 Perl_pp_syscall
 Perl_pp_lock
 Perl_pp_threadsv
diff -ruN perl5.5.640.dist/pp_proto.h perl5.5.640/pp_proto.h
--- perl5.5.640.dist/pp_proto.h	Thu Jan 27 16:53:27 2000
+++ perl5.5.640/pp_proto.h	Mon Feb  7 15:09:25 2000
@@ -383,6 +383,7 @@
 PERL_PPDEF(Perl_pp_sgrent)
 PERL_PPDEF(Perl_pp_egrent)
 PERL_PPDEF(Perl_pp_getlogin)
+PERL_PPDEF(Perl_pp_ghname)
 PERL_PPDEF(Perl_pp_syscall)
 PERL_PPDEF(Perl_pp_lock)
 PERL_PPDEF(Perl_pp_threadsv)
diff -ruN perl5.5.640.dist/pp_sys.c perl5.5.640/pp_sys.c
--- perl5.5.640.dist/pp_sys.c	Wed Feb  2 05:17:45 2000
+++ perl5.5.640/pp_sys.c	Mon Feb  7 15:42:36 2000
@@ -5180,3 +5180,32 @@
 }
 
 #endif /* LOCKF_EMULATE_FLOCK */
+
+PP(pp_ghname)
+{
+    djSP; dTARGET;
+    IV retval;
+    SV *sv;
+#ifdef HAS_GETHOSTNAME
+
+#ifndef MAXHOSTNAMELEN
+# define MAXHOSTNAMELEN 256
+#endif
+
+    char tmps[MAXHOSTNAMELEN];
+
+    EXTEND(SP, 1);
+    retval = PerlProc_gethostname(tmps, sizeof(tmps));
+    if (retval == -1)
+	RETPUSHUNDEF;
+    else {
+	sv = newSVpvn(tmps, strlen(tmps));
+	PUSHs(sv);
+	SvTAINTED_on(sv);
+    }
+
+    RETURN;
+#else
+    DIE(aTHX_ PL_no_func, "gethostname");
+#endif
+}
diff -ruN perl5.5.640.dist/t/op/lex_assign.t perl5.5.640/t/op/lex_assign.t
--- perl5.5.640.dist/t/op/lex_assign.t	Sun Jan  2 14:44:26 2000
+++ perl5.5.640/t/op/lex_assign.t	Mon Feb  7 14:55:44 2000
@@ -310,3 +310,4 @@
 '???'				# semop
 '???'				# getlogin
 '???'				# syscall
+'???'				# gethostname
diff -ruN perl5.5.640.dist/t/op/taint.t perl5.5.640/t/op/taint.t
--- perl5.5.640.dist/t/op/taint.t	Tue Oct 12 10:34:57 1999
+++ perl5.5.640/t/op/taint.t	Mon Feb  7 15:38:22 2000
@@ -605,3 +605,14 @@
     $why =~ s/e/'-'.$$/ge;
     test 149,     tainted $why;
 }
+
+# test that result of gethostname is tainted
+{
+    if ($Config{d_gethname}) {
+	my $hostname = gethostname;
+	test 150, tainted $hostname;
+    }
+    else {
+	for (150) { print "ok $_ # Skipped: gethostname() is not available\n" }
+    }
+}
diff -ruN perl5.5.640.dist/t/pragma/warn/op perl5.5.640/t/pragma/warn/op
--- perl5.5.640.dist/t/pragma/warn/op	Sun Oct 24 06:51:32 1999
+++ perl5.5.640/t/pragma/warn/op	Mon Feb  7 14:59:18 2000
@@ -458,6 +458,24 @@
 ########
 # op.c
 use warnings 'void' ;
+use Config ;
+BEGIN {
+    if ( ! $Config{d_gethname}) {
+	print <<EOM ;
+SKIPPED
+# gethostname not present
+EOM
+	exit
+    }
+}
+gethostname ;			# OP_GETHNAME
+no warnings 'void' ;
+gethname ;			# OP_GETHNAME
+EXPECT
+Useless use of gethostname in void context at - line 13.
+########
+# op.c
+use warnings 'void' ;
 use Config ; BEGIN {
 if ( ! $Config{d_socket}) {
     print <<EOM ;
diff -ruN perl5.5.640.dist/toke.c perl5.5.640/toke.c
--- perl5.5.640.dist/toke.c	Mon Jan 31 22:00:22 2000
+++ perl5.5.640/toke.c	Mon Feb  7 15:11:07 2000
@@ -4174,6 +4174,9 @@
 	case KEY_getlogin:
 	    FUN0(OP_GETLOGIN);
 
+	case KEY_gethostname:
+	    FUN0(OP_GHNAME);
+
 	case KEY_glob:
 	    set_csh();
 	    LOP(OP_GLOB,XTERM);
@@ -5087,6 +5090,7 @@
 		if (strEQ(d,"hostbyname"))	return -KEY_gethostbyname;
 		if (strEQ(d,"hostbyaddr"))	return -KEY_gethostbyaddr;
 		if (strEQ(d,"hostent"))		return -KEY_gethostent;
+		if (strEQ(d,"hostname"))	return -KEY_gethostname;
 	    }
 	    else if (*d == 'n') {
 		if (strEQ(d,"netbyname"))	return -KEY_getnetbyname;

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About