From jean.flouret@infineon.com

To​: perlbug@​perl.org
Subject​: fields package bug
Cc​: marek.rouchal@​infineon.com
Reply-To​: jean.flouret@​infineon.com
Message-Id​: <5.8.3_25447_1092319487@​vlbse201.eu.infineon.com>

This is a bug report for perl from jean.flouret@​infineon.com,
generated with the help of perlbug 1.34 running under perl v5.8.3.

fields package is shifting attribute in following case :

  Let's consider 3 levels of simple hierarchy (-> represents a class
derivation)
 
  A->B->C

condition :

  1/ A, C , and have their own fields ,
  B has an empty list of field.

  2/ A is mixing private attribute and public attribute

 
  In this specific case , the private fields declared for A that are
put after the public one are shifted.

workaround :

  add a "dummy" field for class B, so all level of
  hierarchy have their own fields
 

I put a small testcase to reproduce the trouble below.
The stdout is
  A1​:_A1
  A2​:A2
  A3​:c1
So we can see that the A3 attributed has been shifted.....

Regards,
Jean Flouret

#!/opt/perl_5.8.4/bin/perl

package packageA ;
use fields qw(_A1 A2 _A3);
sub new {
  my __PACKAGE__ $this = shift;
  unless (ref $this)
  {
  $this = fields​::new($this);
  }
  $this->{_A1} = "_A1";
  $this->{A2} = "A2";
  $this->{_A3} = "_A3";
  return $this;
}
sub getA1 {
  my __PACKAGE__ $this = shift ;
  return $this->{_A1};
  }

sub getA2 {
  my __PACKAGE__ $this = shift ;
  return $this->{A2};
  }

sub getA3 {
  my __PACKAGE__ $this = shift ;
  return $this->{_A3} ;
  }

package packageB ;
use base qw(packageA);
use fields qw();
#use fields qw(dummy); #uncomment this line to workaround the bug.

sub new {
  my __PACKAGE__ $this = shift;
  unless (ref $this)
  {
  $this = fields​::new($this);
  }
  $this->SUPER​::new();
  return $this;
}

package packageC ;
use base qw(packageB);
use fields qw(_C1 _C2 _C3);
sub new {
  my __PACKAGE__ $this = shift;
  unless (ref $this)
  {
  $this = fields​::new($this);
  }
  $this->SUPER​::new(@​_);

  $this->{_C1} = "c1";
  $this->{_C2} = "c2";
  $this->{_C3} = "c3";
  return $this;
}

my $Cobject = packageC->new();

print "A1​:".$Cobject->getA1()."\n";
print "A2​:".$Cobject->getA2()."\n";
print "A3​:".$Cobject->getA3()."\n";---

Flags​:
  category=library
  severity=high

Site configuration information for perl v5.8.3​:

Configured by hwadm at Fri Jan 23 08​:22​:08 MET 2004.

Summary of my perl5 (revision 5.0 version 8 subversion 3) configuration​:
  Platform​:
  osname=solaris, osvers=2.8, archname=sun4-solaris-thread-multi
  uname='sunos oak 5.8 generic_108528-27 sun4u sparc sunw,ultra-60 '
  config_args='-Dprefix=/opt/perl_5.8.3 -Dmydomain=.muc.infineon.com
-Dcf_email=perl@​muc.infineon.com -Dinstallusrbinperl=undef
-Dperl5=/opt/perl_5.8.3/bin/perl -Dsitebin=/opt/perl_5.8.3/bin
-Dman1dir=/opt/perl_5.8.3/share/man/man1
-Dman3dir=/opt/perl_5.8.3/share/man/man3
-Dperladmin=perl@​muc.infineon.com -Dprivlib=/opt/perl_5.8.3/share/lib
-Dscriptdir=/opt/perl_5.8.3/share/bin
-Dsitescript=/opt/perl_5.8.3/share/bin
-Dsitelib=/opt/perl_5.8.3/share/lib -Ubincompat5005
-Dlibperl=libperlifx.so -Dcc=gcc -Doptimize=-O2 -Dldflags=-static-libgcc
-Dlddlflags=-G -static-libgcc
-Darchlib=/opt/perl_5.8.3/lib/sun4-solaris-thread-multi
-Dsitearch=/opt/perl_5.8.3/lib/sun4-solaris-thread-multi
-Dlocincpth=/home/hwadm/TWW/SOL/include
-Dloclibpth=/home/hwadm/TWW/SOL/lib -Dglibpth=/usr/lib -Duseshrplib
-Dusethreads -Dpager=/usr/local/bin/less -des'
  hint=recommended, useposix=true, d_sigaction=define
  usethreads=define use5005threads=undef useithreads=define
usemultiplicity=define
  useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
  use64bitint=undef use64bitall=undef uselongdouble=undef
  usemymalloc=n, bincompat5005=undef
  Compiler​:
  cc='gcc', ccflags ='-D_REENTRANT -fno-strict-aliasing
-I/home/hwadm/TWW/SOL/include -D_LARGEFILE_SOURCE
-D_FILE_OFFSET_BITS=64',
  optimize='-O2',
  cppflags='-D_REENTRANT -fno-strict-aliasing
-I/home/hwadm/TWW/SOL/include'
  ccversion='', gccversion='3.2.3', gccosandvers='solaris2.8'
  intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=4321
  d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
  ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t',
lseeksize=8
  alignbytes=8, prototype=define
  Linker and Libraries​:
  ld='gcc', ldflags ='-static-libgcc -L/home/hwadm/TWW/SOL/lib '
  libpth=/home/hwadm/TWW/SOL/lib /usr/lib
  libs=-lsocket -lnsl -lgdbm -ldb -ldl -lm -lpthread -lc
  perllibs=-lsocket -lnsl -ldl -lm -lpthread -lc
  libc=/lib/libc.so, so=so, useshrplib=true, libperl=libperlifx.so
  gnulibc_version=''
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags=' -R
/opt/perl_5.8.3/lib/sun4-solaris-thread-multi/CORE'
  cccdlflags='-fPIC', lddlflags='-G -static-libgcc
-L/home/hwadm/TWW/SOL/lib'

Locally applied patches​:
 

@​INC for perl v5.8.3​:

/var/vob/relman/kernel/vob/HDLDepend/lib/perl/sun4-solaris-thread-multi
  /var/vob/relman/kernel/vob/HDLDepend/lib/perl
  /var/vob/relman/kernel/vob/exechandler/lib/perl
  /var/vob/relman/flows/vob/inwaybase/lib/perl
  /var/vob/relman/kernel/vob/flow/lib/perl

/var/vob/relman/kernel/vob/foundation/lib/perl/sun4-solaris-thread-multi
  /var/vob/relman/kernel/vob/foundation/lib/perl
  /opt/perl_5.8.3/lib/sun4-solaris-thread-multi
  /opt/perl_5.8.3/share/lib
  /opt/perl_5.8.3/lib/sun4-solaris-thread-multi
  /opt/perl_5.8.3/share/lib
  /opt/perl_5.8.3/share/lib
  .

Environment for perl v5.8.3​:
  HOME=/home/flouret
  LANG=C
  LANGUAGE (unset)

LD_LIBRARY_PATH=/opt/gcc_3.2.3/lib​:/usr/lib​:/usr/local/lib​:/opt/cds_5033
-u2/CEN/sw/tools/lib
  LOGDIR (unset)

PATH=/opt/xemacs_21.4.12/bin​:/var/vob/relman/flows/vob/inwaybase/bin​:/op
t/gcc_3.2.3/bin​:/opt/perl_5.8.3/bin​:/var/vob/relman/admin/vob/devenv/bin
:/usr/atria/bin​:/bin​:/usr/bin​:/usr/X/bin​:/usr/dt/bin​:/usr/openwin/demo​:.
:/home/flouret/bin​:/usr/local/bin​:/opt/CTXSmf/bin​:/opt/PURE/releases/Pur
ifyPlusFamily.2003.06.00/sun4_solaris2/bin​:/usr/ucb​:/opt/cds_5033-u2/CEN
/sw/tools/bin​:/opt/cds_5033-u2/CEN/sw/tools/dfII/bin​:/var/vob/relman/flo
ws/vob/layver/bin​:/var/vob/relman/flows/vob/titan/bin​:/var/vob/relman/fl
ows/vob/extractGL/bin​:/var/vob/relman/kernel/vob/exechandler/bin​:/var/vo
b/relman/kernel/vob/flow/bin​:/var/vob/relman/admin/vob/flowtest/bin

PERL5LIB=/var/vob/relman/kernel/vob/HDLDepend/lib/perl​:/var/vob/relman/k
ernel/vob/exechandler/lib/perl​:/var/vob/relman/flows/vob/inwaybase/lib/p
erl​:/var/vob/relman/kernel/vob/flow/lib/perl​:/var/vob/relman/kernel/vob/
foundation/lib/perl
  PERL_BADLANG (unset)
  SHELL=tcsh

From @iabyn

On Fri, Aug 13, 2004 at 06​:40​:56AM -0000, Jean. Flouret @​ infineon. com wrote​:

fields package is shifting attribute in following case :

 Let's consider 3 levels of simple hierarchy  \(\-> represents a class

derivation)

 A\->B\->C

condition :

1/ A\, C \, and have their own fields \, 
 B has an empty list of field\.

2/ A is mixing private attribute and public attribute

 
 In this specific case \, the private fields declared for A that are

put after the public one are shifted.

workaround :

 add a "dummy" field for class B\, so all level of 
 hierarchy have their own fields

I put a small testcase to reproduce the trouble below.
The stdout is
A1​:_A1
A2​:A2
A3​:c1
So we can see that the A3 attributed has been shifted.....

Thanks for the report.

The following 2 patches, once integrated into the 5.8.X branch, should
fix it.

A note to P5pers​:

While fixing this patch, I've discovered that the 5.9.x restricted hashes
techique can give compile-time errors when handling the private fields
of base classes; eg if you have

  package A;
  use fields qw(a1 _a2);
  ...

  package B;
  use base 'A';
  use fields qw(b);
  ...

  my B $b = B->new();

Then $b is a ref to a readonly hash with keys 'a1' and 'b'. Any attempt
by methods within class A to manipulate the '_a2' private field give
compile- or run-time errors.

I'm not sure what the best way to deal with this is. I guess we probably
need to include the private fields as placeholders when the hash is
contructed. This does of course make the private fields accessible from
outside of class A.

Dave.

--
Little fly, thy summer's play my thoughtless hand
has terminated with extreme prejudice.
  (with apologies to William Blake)

Change 23266 by davem@​davem-percy on 2004/09/05 20​:04​:35

  [perl #31078] Fields package bug
  An intermediate class with no fields messes up private fields
  in the base class.

Affected files ...

... //depot/perl/lib/base.pm#29 edit
... //depot/perl/lib/base/t/fields-base.t#4 edit

Differences ...

==== //depot/perl/lib/base.pm#29 (text) ====

==== //depot/perl/lib/base/t/fields-base.t#4 (text) ====

@​@​ -21,7 +21,7 @​@​
}

use strict;
-use Test​::More tests => 28;
+use Test​::More tests => 29;

BEGIN { use_ok('base'); }

@​@​ -224,3 +224,55 @​@​
 
  is ($w, 0, "pseudohash warnings in derived class with no fields of it's own");
}
+
+# [perl #31078] an intermediate class with no additional fields caused
+# hidden fields in base class to get stomped on
+
+{
+ package X;
+ use fields qw(X1 _X2);
+ sub new {
+ my X $self = shift;
+ $self = fields​::new($self) unless ref $self;
+ $self->{X1} = "x1";
+ use Devel​::Peek; Dump($self);
+ $self->{_X2} = "_x2";
+ return $self;
+ }
+ sub get_X2 { my X $self = shift; $self->{_X2} }
+
+ package Y;
+ use base qw(X);
+
+ sub new {
+ my Y $self = shift;
+ $self = fields​::new($self) unless ref $self;
+ $self->SUPER​::new();
+ return $self;
+ }
+
+
+ package Z;
+ use base qw(Y);
+ use fields qw(Z1);
+
+ sub new {
+ my Z $self = shift;
+ $self = fields​::new($self) unless ref $self;
+ $self->SUPER​::new();
+ $self->{Z1} = 'z1';
+ return $self;
+ }
+
+ package main;
+
+ if ($Has_PH) {
+ my Z $c = Z->new();
+ is($c->get_X2, '_x2', "empty intermediate class");
+ }
+ else {
+ SKIP​: {
+ skip "restricted hashes don't support private fields properly", 1;
+ }
+ }
+}

Change 23267 by davem@​davem-percy on 2004/09/05 20​:16​:55

  I somehow managed to omit the base.pm change from #23266

Affected files ...

... //depot/perl/lib/base.pm#30 edit

Differences ...

==== //depot/perl/lib/base.pm#30 (text) ====

@​@​ -152,10 +152,9 @​@​
  }
  }

- unless( keys %$bfields ) {
- foreach my $idx (1..$#{$battr}) {
- $dattr->[$idx] = $battr->[$idx] & INHERITED;
- }
+ foreach my $idx (1..$#{$battr}) {
+ next if defined $dattr->[$idx];
+ $dattr->[$idx] = $battr->[$idx] & INHERITED;
  }
}

The RT System itself - Status changed from 'new' to 'open'

From rick@bort.ca

On Sun, Sep 05, 2004 at 09​:40​:10PM +0100, Dave Mitchell wrote​:

While fixing this patch, I've discovered that the 5.9.x restricted hashes
techique can give compile-time errors when handling the private fields
of base classes; eg if you have

package A;
use fields qw\(a1 \_a2\);
\.\.\.

package B;
use base 'A';
use fields qw\(b\);
\.\.\.

my B $b = B\->new\(\);

Then $b is a ref to a readonly hash with keys 'a1' and 'b'. Any attempt
by methods within class A to manipulate the '_a2' private field give
compile- or run-time errors.

I haven't been able to get a compile-time error. Do you have a test
case? I can see it's quite a mess at run-time though.

I'm not sure what the best way to deal with this is.

Me neither.

--
Rick Delaney
rick@​bort.ca

From @iabyn

On Sun, Sep 05, 2004 at 06​:02​:42PM -0400, Rick Delaney wrote​:

On Sun, Sep 05, 2004 at 09​:40​:10PM +0100, Dave Mitchell wrote​:

While fixing this patch, I've discovered that the 5.9.x restricted hashes
techique can give compile-time errors when handling the private fields
of base classes; eg if you have

package A;
use fields qw\(a1 \_a2\);
\.\.\.

package B;
use base 'A';
use fields qw\(b\);
\.\.\.

my B $b = B\->new\(\);

Then $b is a ref to a readonly hash with keys 'a1' and 'b'. Any attempt
by methods within class A to manipulate the '_a2' private field give
compile- or run-time errors.

I haven't been able to get a compile-time error. Do you have a test
case? I can see it's quite a mess at run-time though.

I think I must have got confused. I can only see run-time errors now.

I'm not sure what the best way to deal with this is.

Me neither.

:-(

--
A walk of a thousand miles begins with a single step...
then continues for another 1,999,999 or so.

p5p@spam.wizbit.be - Status changed from 'open' to 'resolved'