add XS version of Sys::Hostname (from Greg Bacon

<gbacon@itsc.uah.edu>)

p4raw-id: //depot/perl@5110

4 files changed, 239 insertions, 0 deletions

diff --git a/ext/Sys/Hostname/Hostname.pm b/ext/Sys/Hostname/Hostname.pm
new file mode 100644
index 0000000000..1efc897c3b
--- /dev/null
+++ b/ext/Sys/Hostname/Hostname.pm
@@ -0,0 +1,153 @@
+package Sys::Hostname;
+
+use strict;
+
+use Carp;
+
+require Exporter;
+use XSLoader ();
+require AutoLoader;
+
+our @ISA     = qw/ Exporter AutoLoader /;
+our @EXPORT  = qw/ hostname /;
+
+our $VERSION = '1.1';
+
+our $host;
+
+XSLoader::load 'Sys::Hostname', $VERSION;
+
+sub hostname {
+
+  # method 1 - we already know it
+  return $host if defined $host;
+
+  # method 1' - try to ask the system
+  $host = ghname();
+  return $host if defined $host;
+
+  if ($^O eq 'VMS') {
+
+    # method 2 - no sockets ==> return DECnet node name
+    eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] };
+    if ($@) { return $host = $ENV{'SYS$NODE'}; }
+
+    # method 3 - has someone else done the job already?  It's common for the
+    #    TCP/IP stack to advertise the hostname via a logical name.  (Are
+    #    there any other logicals which TCP/IP stacks use for the host name?)
+    $host = $ENV{'ARPANET_HOST_NAME'}  || $ENV{'INTERNET_HOST_NAME'} ||
+            $ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'}      ||
+            $ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'};
+    return $host if $host;
+
+    # method 4 - does hostname happen to work?
+    my($rslt) = `hostname`;
+    if ($rslt !~ /IVVERB/) { ($host) = $rslt =~ /^(\S+)/; }
+    return $host if $host;
+
+    # rats!
+    $host = '';
+    Carp::croak "Cannot get host name of local machine";  
+
+  }
+  elsif ($^O eq 'MSWin32') {
+    ($host) = gethostbyname('localhost');
+    chomp($host = `hostname 2> NUL`) unless defined $host;
+    return $host;
+  }
+  elsif ($^O eq 'epoc') {
+    $host = 'localhost';
+    return $host;
+  }
+  else {  # Unix
+    # is anyone going to make it here?
+
+    # method 2 - syscall is preferred since it avoids tainting problems
+    # XXX: is it such a good idea to return hostname untainted?
+    eval {
+	local $SIG{__DIE__};
+	require "syscall.ph";
+	$host = "\0" x 65; ## preload scalar
+	syscall(&SYS_gethostname, $host, 65) == 0;
+    }
+
+    # method 2a - syscall using systeminfo instead of gethostname
+    #           -- needed on systems like Solaris
+    || eval {
+	local $SIG{__DIE__};
+	require "sys/syscall.ph";
+	require "sys/systeminfo.ph";
+	$host = "\0" x 65; ## preload scalar
+	syscall(&SYS_systeminfo, &SI_HOSTNAME, $host, 65) != -1;
+    }
+
+    # method 3 - trusty old hostname command
+    || eval {
+	local $SIG{__DIE__};
+	local $SIG{CHLD};
+	$host = `(hostname) 2>/dev/null`; # bsdish
+    }
+
+    # method 4 - use POSIX::uname(), which strictly can't be expected to be
+    # correct
+    || eval {
+	local $SIG{__DIE__};
+	require POSIX;
+	$host = (POSIX::uname())[1];
+    }
+
+    # method 5 - sysV uname command (may truncate)
+    || eval {
+	local $SIG{__DIE__};
+	$host = `uname -n 2>/dev/null`; ## sysVish
+    }
+
+    # method 6 - Apollo pre-SR10
+    || eval {
+	local $SIG{__DIE__};
+        my($a,$b,$c,$d);
+	($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6);
+    }
+
+    # bummer
+    || Carp::croak "Cannot get host name of local machine";  
+
+    # remove garbage 
+    $host =~ tr/\0\r\n//d;
+    $host;
+  }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Sys::Hostname - Try every conceivable way to get hostname
+
+=head1 SYNOPSIS
+
+    use Sys::Hostname;
+    $host = hostname;
+
+=head1 DESCRIPTION
+
+Attempts several methods of getting the system hostname and
+then caches the result.  It tries the first available of the C
+library's gethostname(), C<`$Config{aphostname}`>, uname(2),
+C<syscall(SYS_gethostname)>, C<`hostname`>, C<`uname -n`>,
+and the file F</com/host>.  If all that fails it C<croak>s.
+
+All NULs, returns, and newlines are removed from the result.
+
+=head1 AUTHOR
+
+David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt>
+
+Texas Instruments
+
+XS code added by Greg Bacon E<lt>F<gbacon@cs.uah.edu>E<gt>
+
+=cut
+
diff --git a/ext/Sys/Hostname/Hostname.xs b/ext/Sys/Hostname/Hostname.xs
new file mode 100644
index 0000000000..98c07cf58a
--- /dev/null
+++ b/ext/Sys/Hostname/Hostname.xs
@@ -0,0 +1,77 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#if defined(I_UNISTD) && defined(HAS_GETHOSTNAME)
+# include <unistd.h>
+#endif
+
+/* a reasonable default */
+#ifndef MAXHOSTNAMELEN
+#  define MAXHOSTNAMELEN	256
+#endif
+
+/* swiped from POSIX.xs */
+#if defined(__VMS) && !defined(__POSIX_SOURCE)
+#  if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#    include <utsname.h>
+#  endif
+#endif
+
+#if defined(HAS_UNAME) && !defined(WIN32)
+/* XXX need i_sys_utsname in config.sh */
+#  include <sys/utsname.h>
+#endif
+
+MODULE = Sys::Hostname		PACKAGE = Sys::Hostname
+
+void
+ghname()
+    PREINIT:
+    IV   retval = -1;
+    SV  *sv;
+    PPCODE:
+    EXTEND(SP, 1);
+#ifdef HAS_GETHOSTNAME
+    {
+	char tmps[MAXHOSTNAMELEN];
+	retval = PerlSock_gethostname(tmps, sizeof(tmps));
+	sv = newSVpvn(tmps, strlen(tmps));
+    }
+#else
+#  ifdef HAS_PHOSTNAME
+    {
+	PerlIO *io;
+	char tmps[MAXHOSTNAMELEN];
+	char   *p = tmps;
+        char    c;
+	io = PerlProc_popen(PHOSTNAME, "r");
+	if (!io)
+	    goto check_out;
+	while (PerlIO_read(io, &c, sizeof(c)) == 1) {
+	    if (isSPACE(c) || p - tmps >= sizeof(tmps))
+		break;
+	    *p++ = c;
+	}
+	PerlProc_pclose(io);
+	*p = '\0';
+	retval = 0;
+	sv = newSVpvn(tmps, strlen(tmps));
+    }
+#  else
+#    ifdef HAS_UNAME
+    {
+	struct utsname u;
+	if (PerlEnv_uname(&u) == -1)
+	    goto check_out;
+	sv = newSVpvn(u.nodename, strlen(u.nodename));
+        retval = 0;
+    }
+#    endif
+#  endif
+#endif
+    check_out:
+    if (retval == -1)
+	XSRETURN_UNDEF;
+    else
+	PUSHs(sv_2mortal(sv));
diff --git a/ext/Sys/Hostname/Makefile.PL b/ext/Sys/Hostname/Makefile.PL
new file mode 100644
index 0000000000..a0892f643e
--- /dev/null
+++ b/ext/Sys/Hostname/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME                => 'Sys::Hostname',
+    VERSION_FROM        => 'Hostname.pm', 
+    MAN3PODS		=> {}, 	# Pods will be built by installman.
+    XSPROTOARG          => '-noprototypes',
+);
diff --git a/ext/Sys/Syslog/Makefile.PL b/ext/Sys/Syslog/Makefile.PL
index 253130a506..e5edf3e1ba 100644
--- a/ext/Sys/Syslog/Makefile.PL
+++ b/ext/Sys/Syslog/Makefile.PL
@@ -3,5 +3,6 @@ use ExtUtils::MakeMaker;
 WriteMakefile(
     NAME		=> 'Sys::Syslog',
     VERSION_FROM	=> 'Syslog.pm', 
+    MAN3PODS		=> {}, 	# Pods will be built by installman.
     XSPROTOARG          => '-noprototypes',
 );