perl 4.0.00: (no release announcement available)perl-4.0.00

So far, 4.0 is still a beta test version.  For the last production
version, look in pub/perl.3.0/kits@44.

1 files changed, 96 insertions, 0 deletions

diff --git a/msdos/chdir.c b/msdos/chdir.c
new file mode 100644
index 0000000000..6954f9853e
--- /dev/null
+++ b/msdos/chdir.c
@@ -0,0 +1,96 @@
+/*
+ *    (C) Copyright 1990, 1991 Tom Dinger
+ *
+ *    You may distribute under the terms of the GNU General Public License
+ *    as specified in the README file that comes with the perl 4.0 kit.
+ *
+ */
+
+/*
+ * A "DOS-aware" chdir() function, that will change current drive as well.
+ *
+ *	chdir( "B:" )	-- changes to the default directory, on drive B:
+ *	chdir( "C:\FOO" )  changes to the specified directory, on drive C:
+ *	chdir( "\BAR" )    changes to the specified directory on the current
+ *			   drive.
+ */
+
+#include <stdlib.h>
+#include <ctype.h>
+#include <direct.h>
+#include <dos.h>
+#include <errno.h>
+
+#include "config.h"
+#ifdef chdir
+#undef chdir
+#endif
+
+/* We should have the line:
+ *
+ * #define chdir perl_chdir
+ *
+ * in some header for perl (I put it in config.h) so that all
+ * references to chdir() become references to this function.
+ */
+
+/*------------------------------------------------------------------*/
+
+#if defined(BUGGY_MSC5)	/* only needed for MSC 5.1 */
+
+int _chdrive( int drivenum )
+{
+unsigned int	ndrives;
+unsigned int	tmpdrive;
+
+
+_dos_setdrive( drivenum, &ndrives );
+
+/* check for illegal drive letter */
+_dos_getdrive( &tmpdrive );
+
+return (tmpdrive != drivenum) ? -1 : 0 ;
+}
+
+#endif
+
+/*-----------------------------------------------------------------*/
+
+int perl_chdir( char * path )
+{
+int		drive_letter;
+unsigned int	drivenum;
+
+
+if ( path && *path && (path[1] == ':') )
+    {
+    /* The path starts with a drive letter */
+    /* Change current drive */
+    drive_letter = *path;
+    if ( isalpha(drive_letter) )
+	{
+	/* Drive letter legal */
+	if ( islower(drive_letter) )
+	    drive_letter = toupper(drive_letter);
+	drivenum = drive_letter - 'A' + 1;
+
+	/* Change drive */
+	if ( _chdrive( drivenum ) == -1 )
+	    {
+	    /* Drive change failed -- must be illegal drive letter */
+	    errno = ENODEV;
+	    return -1;
+	    }
+
+	/* Now see if that's all we do */
+	if ( ! path[2] )
+	    return 0;		/* no path after drive -- all done */
+	}
+    /* else drive letter illegal -- fall into "normal" chdir */
+    }
+
+/* Here with some path as well */
+return chdir( path );
+
+/* end perl_chdir() */
+}