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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
package OS2::ExtAttr;
use strict;
use XSLoader;
our $VERSION = '0.04';
XSLoader::load 'OS2::ExtAttr', $VERSION;
# Preloaded methods go here.
# Format of the array:
# 0 ead, 1 file name, 2 file handle. 3 length, 4 position, 5 need to write.
sub TIEHASH {
my $class = shift;
my $ea = _create() || die "Cannot create EA: $!";
my $file = shift;
my ($name, $handle);
if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') {
die "File handle is not opened" unless $handle = fileno $file;
_read($ea, undef, $handle, 0);
} else {
$name = $file;
_read($ea, $name, 0, 0);
}
bless [$ea, $name, $handle, 0, 0, 0], $class;
}
sub DESTROY {
my $eas = shift;
# 0 means: discard eas which are not in $eas->[0].
_write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!"
if $eas->[5];
_destroy( $eas->[0] );
}
sub FIRSTKEY {
my $eas = shift;
$eas->[3] = _count($eas->[0]);
$eas->[4] = 1;
return undef if $eas->[4] > $eas->[3];
return _get_name($eas->[0], $eas->[4]);
}
sub NEXTKEY {
my $eas = shift;
$eas->[4]++;
return undef if $eas->[4] > $eas->[3];
return _get_name($eas->[0], $eas->[4]);
}
sub FETCH {
my $eas = shift;
my $index = _find($eas->[0], shift);
return undef if $index <= 0;
return value($eas->[0], $index);
}
sub EXISTS {
my $eas = shift;
return _find($eas->[0], shift) > 0;
}
sub STORE {
my $eas = shift;
$eas->[5] = 1;
add($eas->[0], shift, shift) > 0 or die "Error setting EA: $!";
}
sub DELETE {
my $eas = shift;
my $index = _find($eas->[0], shift);
return undef if $index <= 0;
my $value = value($eas->[0], $index);
_delete($eas->[0], $index) and die "Error deleting EA: $!";
$eas->[5] = 1;
return $value;
}
sub CLEAR {
my $eas = shift;
_clear($eas->[0]);
$eas->[5] = 1;
}
# Here are additional methods:
*new = \&TIEHASH;
sub copy {
my $eas = shift;
my $file = shift;
my ($name, $handle);
if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') {
die "File handle is not opened" unless $handle = fileno $file;
_write($eas->[0], undef, $handle, 0) or die "Cannot write EA: $!";
} else {
$name = $file;
_write($eas->[0], $name, 0, 0) or die "Cannot write EA: $!";
}
}
sub update {
my $eas = shift;
# 0 means: discard eas which are not in $eas->[0].
_write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!";
}
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
__END__
# Below is the stub of documentation for your module. You better edit it!
=head1 NAME
OS2::ExtAttr - Perl access to extended attributes.
=head1 SYNOPSIS
use OS2::ExtAttr;
tie %ea, 'OS2::ExtAttr', 'my.file';
print $ea{eaname};
$ea{myfield} = 'value';
untie %ea;
=head1 DESCRIPTION
The package provides low-level and high-level interface to Extended
Attributes under OS/2.
=head2 High-level interface: C<tie>
The only argument of tie() is a file name, or an open file handle.
Note that all the changes of the tied hash happen in core, to
propagate it to disk the tied hash should be untie()ed or should go
out of scope. Alternatively, one may use the low-level C<update>
method on the corresponding object. Example:
tied(%hash)->update;
Note also that setting/getting EA flag is not supported by the
high-level interface, one should use the low-level interface
instead. To use it on a tied hash one needs undocumented way to find
C<eas> give the tied hash.
=head2 Low-level interface
Two low-level methods are supported by the objects: copy() and
update(). The copy() takes one argument: the name of a file to copy
the attributes to, or an opened file handle. update() takes no
arguments, and is discussed above.
Three convenience functions are provided:
value($eas, $key)
add($eas, $key, $value [, $flag])
replace($eas, $key, $value [, $flag])
The default value for C<flag> is 0.
In addition, all the C<_ea_*> and C<_ead_*> functions defined in EMX
library are supported, with leading C<_ea> and C<_ead> stripped.
=head1 AUTHOR
Ilya Zakharevich, ilya@math.ohio-state.edu
=head1 SEE ALSO
perl(1).
=cut
|
