stas 2004/05/17 15:53:33
Modified: lib/ModPerl MapUtil.pm StructureMap.pm TypeMap.pm WrapXS.pm
Log:
add provision for making struct accessors readonly (with < marker in the
map file)
Revision Changes Path
1.5 +1 -0 modperl-2.0/lib/ModPerl/MapUtil.pm
Index: MapUtil.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/MapUtil.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -u -r1.4 -r1.5
--- MapUtil.pm 4 Mar 2004 06:01:06 -0000 1.4
+++ MapUtil.pm 17 May 2004 22:53:33 -0000 1.5
@@ -25,6 +25,7 @@
our @ISA = qw(Exporter);
+# '<' => 'auto-generated but gives only a read-only access'
my %disabled_map = (
'!' => 'disabled or not yet implemented',
'~' => 'implemented but not auto-generated',
1.5 +10 -3 modperl-2.0/lib/ModPerl/StructureMap.pm
Index: StructureMap.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/StructureMap.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -u -r1.4 -r1.5
--- StructureMap.pm 4 Mar 2004 06:01:06 -0000 1.4
+++ StructureMap.pm 17 May 2004 22:53:33 -0000 1.5
@@ -117,11 +117,18 @@
}
if (s/^(\W)\s*// or $disabled) {
- $map->{$class}->{$_} = undef;
- push @{ $self->{disabled}->{ $1 || '!' } }, "$class.$_";
+ # < denotes a read-only accessor
+ if ($1 && $1 eq '<') {
+ $map->{$class}->{$_} = 'ro';
+ }
+ else {
+ $map->{$class}->{$_} = undef;
+ push @{ $self->{disabled}->{ $1 || '!' } }, "$class.$_";
+ }
+
}
else {
- $map->{$class}->{$_} = 1;
+ $map->{$class}->{$_} = 'rw';
}
}
1.20 +11 -6 modperl-2.0/lib/ModPerl/TypeMap.pm
Index: TypeMap.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/TypeMap.pm,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -u -r1.19 -r1.20
--- TypeMap.pm 4 Mar 2004 06:01:06 -0000 1.19
+++ TypeMap.pm 17 May 2004 22:53:33 -0000 1.20
@@ -289,19 +289,24 @@
return unless $class = $self->map_type($stype);
+ use Apache::TestTrace;
+
for my $e (@{ $struct->{elts} }) {
my($name, $type) = ($e->{name}, $e->{type});
my $rtype;
- next unless $self->structure_map->{$stype}->{$name};
+ # ro/rw/undef(disabled)
+ my $access_mode = $self->structure_map->{$stype}->{$name};
+ next unless $access_mode;
next unless $rtype = $self->map_type($type);
push @elts, {
- name => $name,
- type => $rtype,
- default => $self->null_type($type),
- pool => $self->class_pool($class),
- class => $self->{map}->{$type} || "",
+ name => $name,
+ type => $rtype,
+ default => $self->null_type($type),
+ pool => $self->class_pool($class),
+ class => $self->{map}->{$type} || "",
+ access_mode => $access_mode,
};
}
1.73 +23 -3 modperl-2.0/lib/ModPerl/WrapXS.pm
Index: WrapXS.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/ModPerl/WrapXS.pm,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -u -r1.72 -r1.73
--- WrapXS.pm 14 May 2004 20:57:40 -0000 1.72
+++ WrapXS.pm 17 May 2004 22:53:33 -0000 1.73
@@ -195,8 +195,8 @@
my $class = $struct->{class};
for my $e (@{ $struct->{elts} }) {
- my($name, $default, $type) =
- @{$e}{qw(name default type)};
+ my($name, $default, $type, $access_mode) =
+ @{$e}{qw(name default type access_mode)};
(my $cast = $type) =~ s/:/_/g;
my $val = get_value($e);
@@ -210,7 +210,25 @@
my $attrs = $self->attrs($name);
- my $code = <<EOF;
+ my $code;
+ if ($access_mode eq 'ro') {
+ $code = <<EOF;
+$type
+$name(obj)
+ $class obj
+
+$attrs
+
+ CODE:
+ RETVAL = ($cast) obj->$name;
+
+ OUTPUT:
+ RETVAL
+
+EOF
+ }
+ elsif ($access_mode eq 'rw') {
+ $code = <<EOF;
$type
$name(obj, val=$default)
$class obj
@@ -231,6 +249,8 @@
RETVAL
EOF
+ }
+
push @{ $self->{XS}->{ $struct->{module} } }, {
code => $code,
class => $class,
