1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
package PerlIO::via::symlink;
use 5.008;
use warnings;
use strict;
our $VERSION = '0.05';
=head1 NAME
PerlIO::via::symlink - PerlIO layers for create symlinks
=head1 SYNOPSIS
open $fh, '>:via(symlink)', $fname;
print $fh "link foobar";
close $fh;
=head1 DESCRIPTION
The PerlIO layer C<symlink> allows you to create a symbolic link by
writing to the file handle.
You need to write C"link $name" to the file handle. If the format does
not match, C<close> will fail with EINVAL.
=cut
use Errno qw(EINVAL ENOENT);
use Symbol qw(gensym);
sub PUSHED {
$! = EINVAL, return -1
unless $_[1] eq 'w' || $_[1] eq 'r';
my $self = bless gensym(), $_[0];
*$self->{mode} = $_[1];
return $self;
}
sub OPEN {
my ($self, $fname) = @_;
*$self->{fname} = $fname;
return 1 if *$self->{mode} eq 'w';
lstat ($fname) or return -1;
$! = EINVAL, return -1 unless -l $fname;
*$self->{content} = 'link '.readlink ($fname);
return 1;
}
sub WRITE {
my ($self, $buf) = @_;
*$self->{content} .= $buf;
return length($buf);
}
sub FILL {
my ($self) = @_;
return if *$self->{filled};
++*$self->{filled};
return *$self->{content};
}
sub SEEK {
my ($self) = @_;
delete *$self->{filled};
}
sub CLOSE {
my ($link, $fname, $mode) = @{*{$_[0]}}{qw/content fname mode/};
return 0 if $mode eq 'r';
$link =~ s/^link // or $! = EINVAL, return -1;
symlink $link, $fname or return -1;
return 0;
}
=head1 TEST COVERAGE
----------------------------------- ------ ------ ------ ------ ------ ------
File stmt branch cond sub time total
----------------------------------- ------ ------ ------ ------ ------ ------
blib/lib/PerlIO/via/symlink.pm 100.0 100.0 n/a 100.0 100.0 100.0
Total 100.0 100.0 n/a 100.0 100.0 100.0
----------------------------------- ------ ------ ------ ------ ------ ------
=head1 AUTHORS
Chia-liang Kao E<lt>clkao@clkao.orgE<gt>
=head1 COPYRIGHT
Copyright 2004-2005 by Chia-liang Kao E<lt>clkao@clkao.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
1;
|
