From perl@profvince.com

Created by perl@province.com

This bug isn't specific to 5.10 or to H​::U​::FH, but it gives a
convenient way to show it without writing XS code.

  perl -MHash​::Util​::FieldHash=fieldhash -e 'fieldhash %SIG; @​a = %SIG
= (A => sub { })'

segfaults with backtrace

Program received signal SIGSEGV, Segmentation fault.
0x00000000004788fe in S_magic_methcall (sv=0x12a6d00, mg=0x0,
  meth=0x5a2c13 "EXISTS", flags=0, n=2, val=0x0) at mg.c​:1605
1605 PUSHs(SvTIED_obj(sv, mg));
(gdb) bt
#0 0x00000000004788fe in S_magic_methcall (sv=0x12a6d00, mg=0x0,
  meth=0x5a2c13 "EXISTS", flags=0, n=2, val=0x0) at mg.c​:1605
#1 0x0000000000478bdf in S_magic_methpack (sv=0x12a6d00, mg=0x0,
  meth=0x5a2c13 "EXISTS") at mg.c​:1634
#2 0x0000000000479ea6 in Perl_magic_existspack (sv=0x12a6d00, mg=0x0)
  at mg.c​:1738
#3 0x0000000000482178 in Perl_hv_common (hv=0x1292ce0, keysv=0x12a6940,
  key=0x1258170 "A", klen=1, flags=0, action=8, val=0x0, hash=0) at
hv.c​:486
#4 0x0000000000499932 in Perl_pp_aassign () at pp_hot.c​:1057
#5 0x000000000046beef in Perl_runops_debug () at dump.c​:1931
#6 0x000000000048f677 in S_run_body (oldscope=1) at perl.c​:2384
#7 0x000000000048f133 in perl_run (my_perl=0x1238010) at perl.c​:2302
#8 0x000000000041f8dd in main (argc=4, argv=0x7fffa4ab6b08,
  env=0x7fffa4ab6b30) at perlmain.c​:113
(gdb) call Perl_sv_dump(sv)
SV = NULL(0x0) at 0x12a6d00
  REFCNT = 1
  FLAGS = (TEMP)
(gdb) p mg
$1 = (const MAGIC *) 0x0
(gdb) up 3
#3 0x0000000000482178 in Perl_hv_common (hv=0x1292ce0, keysv=0x12a6940,
  key=0x1258170 "A", klen=1, flags=0, action=8, val=0x0, hash=0) at
hv.c​:486
486 magic_existspack(svret, mg_find(sv,
PERL_MAGIC_tiedelem));
(gdb) l
481 } else {
482 mg_copy((SV*)hv, sv, key, klen);
483 }
484 if (flags & HVhek_FREEKEY)
485 Safefree(key);
486 magic_existspack(svret, mg_find(sv,
PERL_MAGIC_tiedelem));
487 /* This cast somewhat evil, but I'm merely using
NULL/
488 not NULL to return the boolean exists.
489 And I know hv is not NULL. */
490 return SvTRUE(svret) ? (void *)hv : NULL;
(gdb) l 470
465 } /* ISFETCH */
466 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
467 if (mg_find((SV*)hv, PERL_MAGIC_tied) ||
SvGMAGICAL((SV*)hv)) {
468 /* I don't understand why hv_exists_ent has
svret and sv,
469 whereas hv_exists only had one. */
470 SV * const svret = sv_newmortal();
471 sv = sv_newmortal();
472
473 if (keysv || is_utf8) {
474 if (!keysv) {
(gdb) call Perl_sv_dump(hv)
SV = PVHV(0x12428a0) at 0x1292ce0
  REFCNT = 1
  FLAGS = (GMG,SMG,RMG,SHAREKEYS)
  MAGIC = 0x1257f50
  MG_VIRTUAL = &PL_vtbl_uvar
  MG_TYPE = PERL_MAGIC_uvar(U)
  MG_LEN = 24
  MG_PTR = 0x125aab0
"\332`f\233\225\177\0\0\0\0\0\0\0\0\0\0\10\0\0\0\0\0\0\0"
  MAGIC = 0x12a6060
  MG_VIRTUAL = &PL_vtbl_sig
  MG_TYPE = PERL_MAGIC_sig(S)
  ARRAY = 0x12aa1f0
  KEYS = 0
  FILL = 0
  MAX = 127
  RITER = -1
  EITER = 0x0

What happens is that %SIG originally has RMG set, because sig magic
doesn't have set/get magic callbacks. When uvar magic is applied on it
with fieldhash(), GMG is also set. If %SIG is assigned in list context,
pp_aassign calls exist ; and since SvRMAGICAL(hv) && (action &
HV_FETCH_ISEXISTS) && SvGMAGICAL((SV*)hv) is true, the hash is wrongly
handled as a tied hash.

A first memory misread happens with mg_find(sv, PERL_MAGIC_tiedelem),
because sv is not a PVMG (mg_copy couldn't upgrade it since there's no
copy magic in this case). This doesn't cause the segfault in this
example, but it's still wrong.
And even if this would be right, SvTIED_obj(sv, mg) segvs later because
mg (which should be the tied magic token) is righteously NULL.

This example is pretty unlikely to happen in real life, but this problem
applies also to any extension magic that has both get and clear
callbacks (which I think is quite reasonable).

Vincent.

Flags:
    category=core
    severity=low

Site configuration information for perl 5.10.0:

Configured by vince at Sat Sep 27 22:36:33 CEST 2008.

Summary of my perl5 (revision 5 version 10 subversion 0) configuration:
  Platform:
    osname=linux, osvers=2.6.26.3-fuuka.profvince.com,
archname=x86_64-linux-ld
    uname='linux fuuka 2.6.26.3-fuuka.profvince.com #1 smp tue sep 2
23:24:24 cest 2008 x86_64 intel(r) core(tm)2 duo cpu e6750 @ 2.66ghz
genuineintel gnulinux '
    config_args='-des -Dcf_email=vpit@cpan.org
-Dmydomain=fuuka.profvince.com -Dusemorebits -Dman1dir=none
-Dman3dir=none -DDEBUGGING -Doptimize='-g3'
-Dprefix=/home/vince/perl/builds/dbg/5.10.0'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=undef, usemultiplicity=undef
    useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
    use64bitint=define, use64bitall=define, uselongdouble=define
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-DDEBUGGING -fno-strict-aliasing -pipe
-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -I/usr/include/gdbm',
    optimize='-g3',
    cppflags='-DDEBUGGING -fno-strict-aliasing -pipe -I/usr/include/gdbm'
    ccversion='', gccversion='4.3.1', gccosandvers=''
    intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
    ivtype='long', ivsize=8, nvtype='long double', nvsize=16,
Off_t='off_t', lseeksize=8
    alignbytes=16, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib /lib64 /usr/lib64 /usr/local/lib64
    libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
    libc=/lib/libc-2.8.so, so=so, useshrplib=false, libperl=libperl.a
    gnulibc_version='2.8'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
    cccdlflags='-fPIC', lddlflags='-shared -g3 -L/usr/local/lib'

Locally applied patches:
   


@INC for perl 5.10.0:
    /home/vince/perl/builds/dbg/5.10.0/lib/5.10.0/x86_64-linux-ld
    /home/vince/perl/builds/dbg/5.10.0/lib/5.10.0
    /home/vince/perl/builds/dbg/5.10.0/lib/site_perl/5.10.0/x86_64-linux-ld
    /home/vince/perl/builds/dbg/5.10.0/lib/site_perl/5.10.0
    .


Environment for perl 5.10.0:
    HOME=/home/vince
    LANG=fr_FR.UTF-8
    LANGUAGE (unset)
    LC_ALL=fr_FR.UTF-8
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
   
PATH=/home/vince/bin:/home/vince/perl/builds/bin:/usr/local/bin:/usr/bin:/bin:/opt/bin:/usr/x86_64-pc-linux-gnu/gcc-bin/4.3.2:/opt/intel/cce/10.1.018/bin:/usr/local/texlive/2007/bin/x86_64-linux:/usr/games/bin
    PERL_BADLANG (unset)
    SHELL=/bin/bash

From bitcard@profvince.com

perl \-MHash​::Util​::FieldHash=fieldhash \-e 'fieldhash %SIG; @​a =

%SIG
= (A => sub { })'

segfaults with backtrace

This example no longer segfaults in blead, as the result of my own
http​://perl5.git.perl.org/perl.git/commit/218787bdb7a9250de0cc00118d84dcb23ff2f1c5
- because %SIG no longer has RMG set. It may still be a problem in
extensions if one define an ext magic with get and clear, but I don't
see how to forge a pure perl example without the hash being tied.

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