initial import of Win32-Symlink 0.01 from CPAN

git-cpan-module:   Win32-Symlink
git-cpan-version:  0.01
git-cpan-authorid: AUTRIJUS
git-cpan-file:     authors/id/A/AU/AUTRIJUS/Win32-Symlink-0.01.tar.gz

Changes

@@ -0,0 +1,9 @@
+----------------------------------------------------------------------
+r7676:   | 2004-09-18T20:15:51.075244Z
+
+This be 0.01.
+----------------------------------------------------------------------
+r7674:  autrijus | 2004-09-18T19:41:59.869858Z
+
+* Initial checkin of Win32::Symlink
+----------------------------------------------------------------------

MANIFEST

@@ -0,0 +1,11 @@
+pgsymlink.c
+Changes
+Symlink.pm
+Symlink.xs
+Makefile.PL
+MANIFEST
+MANIFEST.SKIP
+README
+SIGNATURE
+t/1-basic.t
+META.yml                                 Module meta-data (added by MakeMaker)

MANIFEST.SKIP

@@ -0,0 +1,9 @@
+#defaults
+^MANIFEST.bak$
+^Makefile$
+^Makefile.old$
+^blib/
+^pm_to_blib$
+^blibdirs$
+^Symlink.(?!pm$|xs$).*$
+^pgsymlink.(?!c$).*$

META.yml

@@ -0,0 +1,10 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
+name:         Win32-Symlink
+version:      0.01
+version_from: Symlink.pm
+installdirs:  site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.21

Makefile.PL

@@ -0,0 +1,14 @@
+#!/usr/bin/perl
+
+use Config;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    'NAME'	    => 'Win32::Symlink',
+    'VERSION_FROM'  => 'Symlink.pm',
+    'AUTHOR'        => 'Autrijus Tang <autrijus@autrijus.org>',
+    'ABSTRACT'      => 'Symbolic links on Win32',
+    (ExtUtils::MakeMaker->VERSION >= 6.21) ? (SIGN => 1) : ()
+);
+
+1;

README

@@ -0,0 +1,28 @@
+This is the README file for Win32::Symlink, a module implementing
+symbolic links on windows.
+
+* Installation
+
+Win32::Symlink uses the standard perl module install process:
+
+cpansign -v		# see SIGNATURE for details
+perl Makefile.PL
+make
+make test
+make install
+
+* Copyright
+
+Copyright 2004 by Autrijus Tang <autrijus@autrijus.org>.
+
+All rights reserved.  You can redistribute and/or modify
+this bundle under the same terms as Perl itself.
+
+See <http://www.perl.com/perl/misc/Artistic.html>.
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:

SIGNATURE

@@ -0,0 +1,33 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.38.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+    % cpansign -v
+
+It would check each file's integrity, as well as the signature's
+validity.  If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 1e3e2eba24956556729d0b1617727fd49761e4e7 Changes
+SHA1 492998085140dadede823affd76d8ffc78e77174 MANIFEST
+SHA1 bcbcf72c19a6fc86f07fd523d9b6e773e5b9247f MANIFEST.SKIP
+SHA1 28da192eaa849010200f0e85eb69e9e1a517602d META.yml
+SHA1 b9658d16261c77f0158b091361c68522fd681d92 Makefile.PL
+SHA1 098af239a2c163482b5d1e99f574bbfc49822901 README
+SHA1 6ad565e51bff0a2f2b6fea11edb8e07a30763934 Symlink.pm
+SHA1 3e07cc67859beba9fd19731e271d9abec2b9f71e Symlink.xs
+SHA1 cf613d720ce01e4c37178d89fb36e952a268a4fe pgsymlink.c
+SHA1 c8023964246f90282f0c9ee17e3d54012a3b8dcd t/1-basic.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.2.3 (FreeBSD)
+
+iD8DBQFBTJmAtLPdNzw1AaARAm0NAJ0USg1MrdvUFLcwhDy/3XAoFNSkxQCdEigP
+bbhkN1OX7u1/HZcjBTB6cAg=
+=G/2S
+-----END PGP SIGNATURE-----

Symlink.pm

@@ -0,0 +1,47 @@
+package Win32::Symlink;
+
+use strict;
+use vars qw($VERSION @ISA);
+use DynaLoader;
+
+@ISA = qw(DynaLoader);
+$VERSION = '0.01';
+
+__PACKAGE__->bootstrap($VERSION);
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::Symlink - Symlink support on Windows
+
+=head1 VERSION
+
+This document describes version 0.01 of Win32::Symlink, released
+September 19, 2004.
+
+=head1 SYNOPSIS
+
+    use Win32::Symlink;
+    symlink( 'from' => 'to' );
+
+=head1 DESCRIPTION
+
+=head1 NOTES
+
+=head1 AUTHORS
+
+Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut

Symlink.xs

@@ -0,0 +1,27 @@
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#ifdef __cplusplus
+}
+#endif
+
+#include "pgsymlink.c"
+
+MODULE = Win32::Symlink		PACKAGE = Win32::Symlink		
+
+int
+symlink(oldpath, newpath)
+    const char * oldpath
+    const char * newpath
+    CODE:
+	if (pgsymlink(oldpath, newpath) == -1) {
+	    RETVAL = 0;
+	}
+	else {
+	    RETVAL = 1;
+	}
+    OUTPUT:
+        RETVAL

pgsymlink.c

@@ -0,0 +1,105 @@
+/*
+ * Source: http://www.mail-archive.com/pgsql-committers@postgresql.org/msg03912.html
+ */
+
+#include <windows.h>
+#include <winioctl.h>
+#include <stdio.h>
+
+/*
+ *	pgsymlink support:
+ *
+ *	This struct is a replacement for REPARSE_DATA_BUFFER which is defined in VC6 winnt.h
+ *	but omitted in later SDK functions.
+ *	We only need the SymbolicLinkReparseBuffer part of the original struct's union.
+ */
+typedef struct
+{
+    DWORD  ReparseTag;
+    WORD   ReparseDataLength;
+    WORD   Reserved;
+    /* SymbolicLinkReparseBuffer */
+        WORD   SubstituteNameOffset;
+        WORD   SubstituteNameLength;
+        WORD   PrintNameOffset;
+        WORD   PrintNameLength;
+        WCHAR PathBuffer[1];
+}
+REPARSE_JUNCTION_DATA_BUFFER;
+
+#define REPARSE_JUNCTION_DATA_BUFFER_HEADER_SIZE   \
+		FIELD_OFFSET(REPARSE_JUNCTION_DATA_BUFFER, SubstituteNameOffset)
+
+/*
+ *	pgsymlink - uses Win32 junction points
+ *
+ *	For reference:	http://www.codeproject.com/w2k/junctionpoints.asp
+ */
+int
+pgsymlink(const char *oldpath, const char *newpath)
+{
+	HANDLE dirhandle;
+	DWORD len;
+	char nativeTarget[MAX_PATH];
+	char *p = nativeTarget;
+	char buffer[MAX_PATH*sizeof(WCHAR) + sizeof(REPARSE_JUNCTION_DATA_BUFFER)];
+	REPARSE_JUNCTION_DATA_BUFFER *reparseBuf = (REPARSE_JUNCTION_DATA_BUFFER*)buffer;
+
+	CreateDirectory(newpath, 0);
+	dirhandle = CreateFile(newpath, GENERIC_READ | GENERIC_WRITE, 
+			0, 0, OPEN_EXISTING, 
+			FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, 0);
+
+	if (dirhandle == INVALID_HANDLE_VALUE)
+		return -1;
+
+	/* make sure we have an unparsed native win32 path */
+	if (memcmp("\\??\\", oldpath, 4))
+		sprintf(nativeTarget, "\\??\\%s", oldpath);
+	else
+		strcpy(nativeTarget, oldpath);
+
+	while ((p = strchr(p, '/')) != 0)
+		*p++ = '\\';
+
+	len = strlen(nativeTarget) * sizeof(WCHAR);
+	reparseBuf->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
+	reparseBuf->ReparseDataLength = (unsigned short)(len + 12);
+	reparseBuf->Reserved = 0;
+	reparseBuf->SubstituteNameOffset = 0;
+	reparseBuf->SubstituteNameLength = (unsigned short)(len);
+	reparseBuf->PrintNameOffset = (unsigned short)(len+sizeof(WCHAR));
+	reparseBuf->PrintNameLength = 0;
+	MultiByteToWideChar(CP_ACP, 0, nativeTarget, -1,
+						reparseBuf->PathBuffer, MAX_PATH);
+
+	/*
+	 * FSCTL_SET_REPARSE_POINT is coded differently depending on SDK version;
+	 * we use our own definition
+	 */
+	if (!DeviceIoControl(dirhandle, 
+		CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_ANY_ACCESS),
+		reparseBuf, 
+		reparseBuf->ReparseDataLength + REPARSE_JUNCTION_DATA_BUFFER_HEADER_SIZE,
+		0, 0, &len, 0))
+	{
+		LPSTR msg;
+
+		errno=0;
+		FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM,
+					  NULL, GetLastError(), 
+					  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+					  (LPSTR)&msg, 0, NULL );
+		Perl_warn(aTHX_ "Error setting junction for %s: %s", nativeTarget, msg);
+
+		LocalFree(msg);
+
+		CloseHandle(dirhandle);
+		RemoveDirectory(newpath);
+		return -1;
+	}
+
+	CloseHandle(dirhandle);
+
+	return 0;
+}

t/1-basic.t

@@ -0,0 +1,36 @@
+use strict;
+use Test;
+BEGIN { plan tests => 3 };
+
+use FindBin;
+use File::Spec;
+use Win32::Symlink;
+
+ok(Win32::Symlink->VERSION);
+
+my $foo = File::Spec->catdir($FindBin::Bin, 'foo');
+mkdir $foo or die $!;
+
+my $has_symlink = eval { Win32::Symlink::symlink( $foo => "$foo.new" ) };
+
+if (!$has_symlink) {
+    skip(1);
+    skip(1);
+    exit;
+}
+
+ok(-d "$foo.new");
+
+open FH, "> ".File::Spec->catfile($foo, 'bar') or die $!;
+print FH "TEST";
+close FH;
+
+open FH, "< ".File::Spec->catfile("$foo.new", 'bar') or die $!;
+ok(scalar <FH>, "TEST");
+close FH;
+
+END {
+    unlink File::Spec->catfile($foo, 'bar');
+    rmdir "$foo.new";
+    rmdir $foo;
+}