1package OS2::ExtAttr;
2
3use strict;
4use XSLoader;
5
6our $VERSION = '0.04';
7XSLoader::load 'OS2::ExtAttr', $VERSION;
8
9# Preloaded methods go here.
10
11# Format of the array:
12# 0 ead, 1 file name, 2 file handle. 3 length, 4 position, 5 need to write.
13
14sub TIEHASH {
15  my $class = shift;
16  my $ea = _create() || die "Cannot create EA: $!";
17  my $file = shift;
18  my ($name, $handle);
19  if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') {
20    die "File handle is not opened" unless $handle = fileno $file;
21    _read($ea, undef, $handle, 0);
22  } else {
23    $name = $file;
24    _read($ea, $name, 0, 0);
25  }
26  bless [$ea, $name, $handle, 0, 0, 0], $class;
27}
28
29sub DESTROY {
30  my $eas = shift;
31  # 0 means: discard eas which are not in $eas->[0].
32  _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!"
33    if $eas->[5];
34  _destroy( $eas->[0] );
35}
36
37sub FIRSTKEY {
38  my $eas = shift;
39  $eas->[3] = _count($eas->[0]);
40  $eas->[4] = 1;
41  return undef if $eas->[4] > $eas->[3];
42  return _get_name($eas->[0], $eas->[4]);
43}
44
45sub NEXTKEY {
46  my $eas = shift;
47  $eas->[4]++;
48  return undef if $eas->[4] > $eas->[3];
49  return _get_name($eas->[0], $eas->[4]);
50}
51
52sub FETCH {
53  my $eas = shift;
54  my $index = _find($eas->[0], shift);
55  return undef if $index <= 0;
56  return value($eas->[0], $index);
57}
58
59sub EXISTS {
60  my $eas = shift;
61  return _find($eas->[0], shift) > 0;
62}
63
64sub STORE {
65  my $eas = shift;
66  $eas->[5] = 1;
67  add($eas->[0], shift, shift) > 0 or die "Error setting EA: $!";
68}
69
70sub DELETE {
71  my $eas = shift;
72  my $index = _find($eas->[0], shift);
73  return undef if $index <= 0;
74  my $value = value($eas->[0], $index);
75  _delete($eas->[0], $index) and die "Error deleting EA: $!";
76  $eas->[5] = 1;
77  return $value;
78}
79
80sub CLEAR {
81  my $eas = shift;
82  _clear($eas->[0]);
83  $eas->[5] = 1;
84}
85
86# Here are additional methods:
87
88*new = \&TIEHASH;
89
90sub copy {
91  my $eas = shift;
92  my $file = shift;
93  my ($name, $handle);
94  if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') {
95    die "File handle is not opened" unless $handle = fileno $file;
96    _write($eas->[0], undef, $handle, 0) or die "Cannot write EA: $!";
97  } else {
98    $name = $file;
99    _write($eas->[0], $name, 0, 0) or die "Cannot write EA: $!";
100  }
101}
102
103sub update {
104  my $eas = shift;
105  # 0 means: discard eas which are not in $eas->[0].
106  _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!";
107}
108
109# Autoload methods go after =cut, and are processed by the autosplit program.
110
1111;
112__END__
113# Below is the stub of documentation for your module. You better edit it!
114
115=head1 NAME
116
117OS2::ExtAttr - Perl access to extended attributes.
118
119=head1 SYNOPSIS
120
121  use OS2::ExtAttr;
122  tie %ea, 'OS2::ExtAttr', 'my.file';
123  print $ea{eaname};
124  $ea{myfield} = 'value';
125
126  untie %ea;
127
128=head1 DESCRIPTION
129
130The package provides low-level and high-level interface to Extended
131Attributes under OS/2.
132
133=head2 High-level interface: C<tie>
134
135The only argument of tie() is a file name, or an open file handle.
136
137Note that all the changes of the tied hash happen in core, to
138propagate it to disk the tied hash should be untie()ed or should go
139out of scope. Alternatively, one may use the low-level C<update>
140method on the corresponding object. Example:
141
142  tied(%hash)->update;
143
144Note also that setting/getting EA flag is not supported by the
145high-level interface, one should use the low-level interface
146instead. To use it on a tied hash one needs undocumented way to find
147C<eas> give the tied hash.
148
149=head2 Low-level interface
150
151Two low-level methods are supported by the objects: copy() and
152update(). The copy() takes one argument: the name of a file to copy
153the attributes to, or an opened file handle. update() takes no
154arguments, and is discussed above.
155
156Three convenience functions are provided:
157
158  value($eas, $key)
159  add($eas, $key, $value [, $flag])
160  replace($eas, $key, $value [, $flag])
161
162The default value for C<flag> is 0.
163
164In addition, all the C<_ea_*> and C<_ead_*> functions defined in EMX
165library are supported, with leading C<_ea> and C<_ead> stripped.
166
167=head1 AUTHOR
168
169Ilya Zakharevich, ilya@math.ohio-state.edu
170
171=head1 SEE ALSO
172
173perl(1).
174
175=cut
176