perl segmentation fault report #788

p5pRT · 1999-10-26T04:19:16Z

Migrated from rt.perl.org#1715 (status was 'resolved')

Searchable as RT1715$

p5pRT · 1999-10-26T04:19:16Z

From lvirden@cas.org

-----------------------------------------------------------------
I am getting a core dump today from perl. I'm uncertain what to send along.
Right now, my perl isn't compiled with -g - is there a way that I can
recompile with -g without having to go thru all the Configure prompts?

$ gdb $(whence perl) core
GDB is free software and you are welcome to distribute copies of it
under certain conditions; type "show copying" to see the conditions.
There is absolutely no warranty for GDB; type "show warranty" for details.
GDB 4.16 (sparc-sun-solaris2.6),
Copyright 1996 Free Software Foundation, Inc...(no debugging symbols found)...
Core was generated by `perl -w getdata.pl'.
Program terminated with signal 11, Segmentation fault.
Reading symbols from /usr/lib/libsocket.so.1...(no debugging symbols found)...
done.
Reading symbols from /usr/lib/libnsl.so.1...(no debugging symbols found)...
done.
Reading symbols from /usr/lib/libdl.so.1...(no debugging symbols found)...done.
Reading symbols from /usr/lib/libm.so.1...(no debugging symbols found)...done.
Reading symbols from /usr/lib/libc.so.1...(no debugging symbols found)...done.
Reading symbols from /usr/lib/libsec.so.1...(no debugging symbols found)...
done.
Reading symbols from /usr/lib/libmp.so.2...(no debugging symbols found)...done.
Reading symbols from /usr/platform/SUNW,Ultra-5_10/lib/libc_psr.so.1...
(no debugging symbols found)...done.
Reading symbols from /vol/lwv26ldatae/lib/perl5/5.006/sun4-solaris/auto/IO/IO.so...(no debugging symbols found)...done.
Reading symbols from /vol/lwv26ldatae/lib/perl5/5.006/sun4-solaris/auto/Socket/Socket.so...(no debugging symbols found)...done.
Reading symbols from /usr/lib/nss_nis.so.1...(no debugging symbols found)...
done.
#0 0x1397b0 in Perl_re_intuit_start ()
(gdb) where
#0 0x1397b0 in Perl_re_intuit_start ()
#1 0x13b25c in Perl_regexec_flags ()
#2 0xb9608 in Perl_pp_subst ()
#3 0xaf938 in Perl_runops_debug ()
#4 0x2c67c in S_run_body ()
#5 0xf67b8 in Perl_vdefault_protect ()
#6 0xf6658 in Perl_default_protect ()
#7 0x2c068 in perl_run ()
#8 0x28054 in main ()
(gdb)

The script in question is:

#!/usr/bin/perl
#******************************************************************************
#
# Showtimes - Movie showtimes for the Palm Computing Platform
# Copyright (C) 1999 J Robert Ray
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
#
# ---
#
# $Source: /usr/local/src/CVS/showtimes/script/getdata.pl,v $
# $Revision: 1.12 $ $Date: 1999/05/01 16:23:22 $
# Checked in by: $Author: robert $
#
#*******************************************************************************
use strict;
use LWP::UserAgent;
use Time::Local;

#################################################################################
##
## The configuration for this script has moved!
##
## Please refer to the file called getdata.cfg for all your customization needs
##
#################################################################################

##############################################################
############### ################
############### No user servicable parts below! ################
############### ################
##############################################################

my $Parser = "yahoo";
my @URLs = ();
my $DestDir = ".";
my $FlipReg = 0;
my @UserNums = ();
my $Proxy = "";
my $ProxyUsername = "";
my $ProxyPassword = "";
my $TheaterList = "";
my %TheaterIgnore = ();
my $runtime = time ();
my $ConfigPath = ".";

ParseParams ();

chdir ( $ConfigPath );

LoadConfig ();

if ( $FlipReg == 1 )
{
$DestDir = ".";
}

#
# Do some sanity checking on the configuration
#
if ( !length ( $DestDir ))
{
errormsg ( "You have not set your DESTDIR in the configuration file. Please open the configuration file and follow the instructions therein to customize this script." );

pause ();
exit 1;
}

if ( ! -d $DestDir )
{
errormsg ( "The path you have set DESTDIR to does not exist. It is possible you have not yet edited the configuration file to customize this script. Verify that the path is correct and try again." );

pause ();
exit 1;
}

if ( $#URLs == -1 )
{
errormsg ( "You do not have any URLs configured in the configuration file. Please add a URL and try again." );

pause ();
exit 1;
}

if ( $TheaterList ne "" )
{
if ( open ( THEATERLIST, "<$TheaterList" ))
{
foreach my $line ( <THEATERLIST> )
{
chomp $line;

if ( $line =~ /^(.*\w)\s*ignore\s*$/i )
{
$TheaterIgnore{ $1 } = 1;
}
elsif ( $line =~ /^(.*\w)\s*$/ )
{
$TheaterIgnore{ $1 } = 0;
}
}
close ( THEATERLIST );
}
}

#
# Set up the user agent object
#
my $ua = new LWP::UserAgent;
$ua->agent ( 'Mozilla/5.0' );

#
# See if we are using a proxy
# Proxy support adapted from code by Xev Glitter (Xev.Glitter@gs.com)
#
if ( $Proxy ne "" )
{
$ua->proxy ( ['http'], $Proxy );
}

my $nURL = 0;
my $nDate = 0;
my $nTheater = 0;
my $nMovie = 0;
my $nShowtime = 0;
my $nTimeString = 0;

my %hDates = ();
my %hTempDates = ();
my %hTheaters = ();
my %hTempTheaters = ();
my %hMovies = ();
my %hTempMovies = ();
my %hShowtimes = ();
my %hTempShowtimes = ();
my %hTimeStrings = ();
my %hTempTimeStrings = ();

print "\n\n";

foreach my $URL ( @URLs ) {
$nURL++;

#
# Decide which parser to use
#
if ( $URL =~ /au\..*yahoo/ )
{
$Parser = "au.yahoo";
}
elsif ( $URL =~ /yahoo/ )
{
$Parser = "yahoo";
}
elsif ( $URL =~ /scoot/ )
{
$Parser = "scoot";
}
elsif ( $URL =~ /allocine/ )
{
$Parser = "allocine";
}

print "Grabbing URL $nURL of " . ( $#URLs + 1 ) . " from $Parser...";
my $content = grabpage ($URL);
print "Done!\n\n";

if ( $Parser eq "yahoo" ) {
YahooParse ( $content );
}
elsif ( $Parser eq "scoot" ) {
ScootParse ( $content );
}
elsif ( $Parser eq 'au.yahoo' ) {
auYahooParse ($content , $URL);
}
elsif ( $Parser eq 'allocine' ) {
AlloCineParse ( $content , $URL );
}
else {
errormsg ( "Unknown parser. How did this happen?" );
pause ();
exit 1;
}
}

#
# Write out the date database
#
if ( open ( PDB, ">$DestDir/ST_Dates.pdb" ))
{
binmode ( PDB );
WritePDBHeader ( "ST_Dates", scalar keys %hDates );
WriteDatePDB ();
close ( PDB );
}
else
{
errormsg ( "Cannot open '$DestDir/ST_Dates.pdb' for writing.\nError message: ($!)" );
pause ();
exit 1;
}

#
# Write out the theater database
#
if ( open ( PDB, ">$DestDir/ST_Thtrs.pdb" ))
{
binmode ( PDB );
WritePDBHeader ( "ST_Theaters", scalar keys %hTheaters );
WriteTheaterPDB ();
close ( PDB );
}
else
{
errormsg ( "Cannot open '$DestDir/ST_Thtrs.pdb' for writing.\nError message: ($!)" );
pause ();
exit 1;
}

#
# Write out the movie database
#
if ( open ( PDB, ">$DestDir/ST_Mvies.pdb" ))
{
binmode ( PDB );
WritePDBHeader ( "ST_Movies", scalar keys %hMovies );
WriteMoviePDB ();
close ( PDB );
}
else
{
errormsg ( "Cannot open '$DestDir/ST_Mvies.pdb' for writing.\nError message: ($!)" );
pause ();
exit 1;
}

#
# Write out the string database
#
if ( open ( PDB, ">$DestDir/ST_Strgs.pdb" ))
{
binmode ( PDB );
WritePDBHeader ( "ST_Strings", scalar keys %hTimeStrings );
WriteStringPDB ();
close ( PDB );
}
else
{
errormsg ( "Cannot open '$DestDir/ST_Strgs.pdb' for writing.\nError message: ($!)" );
pause ();
exit 1;
}

#
# Translate the showtime ID's
#
foreach my $showtime ( keys %hShowtimes )
{
$hShowtimes{ $showtime }{ "MID" } = $hMovies{ $hShowtimes{ $showtime }{ "MID" }}{ "Index" };
$hShowtimes{ $showtime }{ "TID" } = $hTheaters{ $hShowtimes{ $showtime }{ "TID" }}{ "Index" };
$hShowtimes{ $showtime }{ "DID" } = $hDates{ $hShowtimes{ $showtime }{ "DID" }}{ "Index" };
}

#
# Write out the showtime database
#
if ( open ( PDB, ">$DestDir/ST_Times.pdb" ))
{
binmode ( PDB );
WritePDBHeader ( "ST_Times", scalar keys %hShowtimes );
WriteShowtimePDB ();
close ( PDB );
}
else
{
errormsg ( "Cannot open '$DestDir/ST_Times.pdb' for writing.\nError message: ($!)" );
pause ();
exit 1;
}

if ( $FlipReg )
{
print "\nInstalling data files.\n\n";
foreach my $UserNum ( @UserNums )
{
system ( "FlipReg2.exe \"$UserNum\"" );
}
}

#
# Write out the theater file, if the user requests one
#
if ( $TheaterList ne "" )
{
if ( open ( THEATERLIST, ">$TheaterList" ))
{
foreach my $theater ( sort keys %TheaterIgnore )
{
print THEATERLIST "$theater";
if ( $TheaterIgnore{ $theater })
{
printspaces ( 50 - length ( $theater ) - 1 );
print THEATERLIST "ignore";
}
print THEATERLIST "\n";
}
close ( THEATERLIST );
}
else
{
errormsg ( "Unable to create THEATERLIST file '$TheaterList' for writing!\nError message: ($!)" );
pause ();
}
}

print "\n\nScript Complete.\n\n";

#####################
# #
# subroutines below #
# #
#####################

sub LoadConfig
{
# Try to open the config file
unless ( open ( CONFIG, "getdata.cfg" ))
{
errormsg ( "Unable to open the configuration file, $ConfigPath/getdata.cfg. The script looks in the current directory for this file, unless you specify a path with the command line option -d." );
pause ();

exit 1;
}

foreach my $line ( <CONFIG> )
{
if ( $line =~ /^[\#\s\n]/ )
{
next;
}

chomp $line;

( my $key, my $value ) = split ( /\s+/, $line, 2 );

SWITCH: {
$key eq "URL" && do { push ( @URLs, $value ); last SWITCH; };
$key eq "DESTDIR" && do { $DestDir = $value; last SWITCH; };
$key eq "FLIPREG" && do { $FlipReg = $value; last SWITCH; };
$key eq "USERNUM" && do { push ( @UserNums, $value ); last SWITCH; };
$key eq "PROXY" && do { $Proxy = $value; last SWITCH; };
$key eq "PROXYUSERNAME" && do { $ProxyUsername = $value; last SWITCH; };
$key eq "PROXYPASSWORD" && do { $ProxyPassword = $value; last SWITCH; };
$key eq "THEATERLIST" && do { $TheaterList = $value; last SWITCH; };
}
}

close ( CONFIG );
}

#
# Get the web page
#

sub grabpage {
my ($URL) = @_;

my $request = new HTTP::Request ( 'GET', $URL );

#
# Set the proxy authentication stuff if need be
#
if (( $ProxyUsername ne "" ) && ( $ProxyPassword ne "" ))
{
$request->proxy_authorization_basic ( $ProxyUsername, $ProxyPassword );
}

my $response = $ua->request ( $request );

my $content;
if ( $response->is_success )
{
$content = $response->content;
return $content;
}
else
{
my $errmsg = "Error retreiving web page!\nMake sure you are connected to the internet and that the \$URL variable contains a valid URL.";
if ( $Proxy ne "" )
{
$errmsg .= " Also make sure that your proxy settings are correct.";
}
else
{
$errmsg .= " If you are behind a firewall or are using a proxy, please configure the proxy settings.";
}

print "\n\n\n";
errormsg ( $errmsg );

print "\n\nLWP returned:\n\n";
print $response->status_line;

pause ();
exit 1;
}
}

sub WritePDBHeader
{
my $DBName = $_[0];
my $nRecords = $_[1];

print "Writing pdb $DBName with $nRecords records.\n";

my $attributes = 0x8000;
my $version = 1;
if ( $Parser eq "scoot" )
{
$version = 2;
}
elsif ( $Parser eq "allocine" )
{
$version = 3;
}
elsif ( $Parser eq "au.yahoo" )
{
$version = 4;
}

my $now = time ();
#
# If we are running on a system where the epoch is 1 Jan, 1970,
# add 2082844800 seconds to the result. (The number of seconds
# between 1 Jan, 1904 and 1 Jan, 1970.
#
if ( timegm ( 0, 0, 0, 1, 0, 1970 ) == 0 )
{
$now += 2082844800;
}

my $creationdate = $now;
my $modificationdate = $now;
my $lastbackupdate = $now;
my $modificationnumber = 1;
my $appinfoid = 0;
my $sortinfoid = 0;
my $uniqueidseed = 0;
my $nextrecordlistid = 0;

# Write out the main header

syswrite ( PDB,

pack ( "a32nnNNNNNNa4a4NNn",

$DBName,
$attributes,
$version,
$creationdate,
$modificationdate,
$lastbackupdate,
$modificationnumber,
$appinfoid,
$sortinfoid,
"Data",
"OCMv",
$uniqueidseed,
$nextrecordlistid,
$nRecords
),

78 );
}

sub WriteDatePDB
{
my $nOffset = 80 + 8 * scalar keys %hDates;

# Write out the headers
my $index = 0;
foreach my $date ( sort{ $hDates{ $a }{ "Date" } <=> $hDates{ $b }{ "Date" }} keys %hDates )
{
# Remember what order we wrote them out in
$hDates{ $date }{ "Index" } = $index;

syswrite ( PDB, pack ( "N", $nOffset ), 4 ); # Offset
syswrite ( PDB, pack ( "x" ), 1 ); # Attributes

syswrite ( PDB, pack ( "xxx" ), 3 ); # Unique ID, leave zero

$nOffset += GetDateSize ( $date );
$index++;
}

# Pad two bytes
syswrite ( PDB, pack ( "xx" ), 2 );

# Write out the data
foreach my $date ( sort{ $hDates{ $a }{ "Date" } <=> $hDates{ $b }{ "Date" }} keys %hDates )
{
# Write the date
syswrite ( PDB, pack ( "N", $hDates{ $date }{ "Date" }), 4 );
}
}

sub GetDateSize
{
my $key = $_[0];

my $size = 4; # one int

return $size;
}

sub WriteTheaterPDB
{
my $nOffset = 80 + 8 * scalar keys %hTheaters;

# Write out the headers
my $index = 0;
foreach my $theater ( sort{ uc ( $hTheaters{ $a }{ "Name" }) cmp uc ( $hTheaters{ $b }{ "Name" })} keys %hTheaters )
{
# Remember what order we wrote them out in
$hTheaters{ $theater }{ "Index" } = $index;

syswrite ( PDB, pack ( "N", $nOffset ), 4 ); # Offset
syswrite ( PDB, pack ( "x" ), 1 ); # Attributes

syswrite ( PDB, pack ( "xxx" ), 3 ); # Unique ID, leave zero

$nOffset += GetTheaterSize ( $theater );
$index++;
}

# Pad two bytes
syswrite ( PDB, pack ( "xx" ), 2 );

# Write out the data
foreach my $theater ( sort{ uc ( $hTheaters{ $a }{ "Name" }) cmp uc ( $hTheaters{ $b }{ "Name" })} keys %hTheaters )
{
# Write the offset to the info
syswrite ( PDB, pack ( "n", length ( $hTheaters{ $theater }{ "Name" }) + 1 ), 2 );

# Write the name
syswritestr ( $hTheaters{ $theater }{ "Name" });

# Write the info
syswritestr ( $hTheaters{ $theater }{ "Info" });
}
}

sub GetTheaterSize
{
my $key = $_[0];

my $size = 4; # Two strings, two nulls, one offset
$size += length ( $hTheaters{ $key }{ "Name" });
$size += length ( $hTheaters{ $key }{ "Info" });

return $size;
}

sub WriteMoviePDB
{
my $nOffset = 80 + 8 * scalar keys %hMovies;

# Write out the headers
my $index = 0;
foreach my $movie ( sort{ uc ( $hMovies{ $a }{ "Name" }) cmp uc ( $hMovies{ $b }{ "Name" })} keys %hMovies )
{
# Remember what order we wrote them out in
$hMovies{ $movie }{ "Index" } = $index;

syswrite ( PDB, pack ( "N", $nOffset ), 4 ); # Offset
syswrite ( PDB, pack ( "x" ), 1 ); # Attributes

syswrite ( PDB, pack ( "xxx" ), 3 ); # Unique ID, leave zero

$nOffset += GetMovieSize ( $movie );
$index++;
}

# Pad two bytes
syswrite ( PDB, pack ( "xx" ), 2 );

# Write out the data
foreach my $movie ( sort{ uc ( $hMovies{ $a }{ "Name" }) cmp uc ( $hMovies{ $b }{ "Name" })} keys %hMovies )
{
# Write the offset to the info
my $ratingoffset = length ( $hMovies{ $movie }{ "Name" }) + 1;
my $lengthoffset = $ratingoffset + 1;
if ( defined( $hMovies{ $movie }{ "Rating" }))
{
$lengthoffset = $ratingoffset + length ( $hMovies{ $movie }{ "Rating" }) + 1;
}
syswrite ( PDB, pack ( "nn", $ratingoffset, $lengthoffset ), 4 );

# Write the name
syswritestr ( $hMovies{ $movie }{ "Name" });

# Write the rating, if it exists
if ( defined( $hMovies{ $movie }{ "Rating" }))
{
syswritestr( $hMovies{ $movie }{ "Rating" });
}
else
{
# write out a NULL
syswrite ( PDB, pack ( "x" ), 1 );
}

# Write out the length, if it exists
if ( defined( $hMovies{ $movie }{ "Length" }))
{
syswritestr( $hMovies{ $movie }{ "Length" });
}
else
{
# write out a NULL
syswrite ( PDB, pack ( "x" ), 1 );
}
}
}

sub GetMovieSize
{
my $key = $_[0];

my $size = 7; # Three strings, three nulls, two offsets
if ( defined( $hMovies{ $key }{ "Name" }))
{
$size += length ( $hMovies{ $key }{ "Name" });
}
if ( defined( $hMovies{ $key }{ "Rating" }))
{
$size += length ( $hMovies{ $key }{ "Rating" });
}
if ( defined( $hMovies{ $key }{ "Length" }))
{
$size += length ( $hMovies{ $key }{ "Length" });
}

return $size;
}

sub WriteShowtimePDB
{
my $nOffset = 80 + 8 * scalar keys %hShowtimes;

# Write out the headers
my $index = 0;
foreach my $showtime ( sort{
$hShowtimes{ $a }{ "MID" } <=> $hShowtimes{ $b }{ "MID" } ||
$hShowtimes{ $a }{ "TID" } <=> $hShowtimes{ $b }{ "TID" } ||
$hShowtimes{ $a }{ "DID" } <=> $hShowtimes{ $b }{ "DID" }
} keys %hShowtimes )
{
syswrite ( PDB, pack ( "N", $nOffset ), 4 ); # Offset
syswrite ( PDB, pack ( "x" ), 1 ); # Attributes

syswrite ( PDB, pack ( "xxx" ), 3 ); # Unique ID, leave zero

$nOffset += GetShowtimeSize ( $showtime );
$index++;
}

# Pad two bytes
syswrite ( PDB, pack ( "xx" ), 2 );

# Write out the data
foreach my $showtime ( sort{
$hShowtimes{ $a }{ "MID" } <=> $hShowtimes{ $b }{ "MID" } ||
$hShowtimes{ $a }{ "TID" } <=> $hShowtimes{ $b }{ "TID" } ||
$hShowtimes{ $a }{ "DID" } <=> $hShowtimes{ $b }{ "DID" }
} keys %hShowtimes )
{
# Write the MID, TID, DID, SID
syswrite ( PDB, pack ( "nnnn", $hShowtimes{ $showtime }{ "MID" }, $hShowtimes{ $showtime }{ "TID" }, $hShowtimes{ $showtime }{ "DID" }, $hShowtimes{ $showtime }{ "SID" }), 8 );
}
}

sub GetShowtimeSize
{
my $key = $_[0];

my $size = 8; # four shorts

return $size;
}

sub WriteStringPDB
{
my $nOffset = 80 + 8 * scalar keys %hTimeStrings;

# Write out the headers
my $index = 0;
foreach my $string ( sort{ $a <=> $b } keys %hTimeStrings )
{
syswrite ( PDB, pack ( "N", $nOffset ), 4 ); # Offset
syswrite ( PDB, pack ( "x" ), 1 ); # Attributes

syswrite ( PDB, pack ( "xxx" ), 3 ); # Unique ID, leave zero

$nOffset += GetStringSize ( $string );
$index++;
}

# Pad two bytes
syswrite ( PDB, pack ( "xx" ), 2 );

# Write out the data
foreach my $string ( sort{ $a <=> $b } keys %hTimeStrings )
{
# Write the string
syswritestr ( $hTimeStrings{ $string }{ "String" });
}
}

sub GetStringSize
{
my $key = $_[0];

my $size = 1; # one string, one null
if ( defined( $hTimeStrings{ $key }{ "String" }))
{
$size += length ( $hTimeStrings{ $key }{ "String" });
}

return $size;
}

sub syswritestr
{
syswrite ( PDB, $_[0], length ( $_[0] ));
syswrite ( PDB, pack ( "x" ), 1 );
}

sub errormsg
{
printmsg( "GETDATA.PL ERROR:", $_[0] );
}

sub printmsg
{
#Print a message, with the given line leader, and word wrap the message
#so that each line of the message doesn't exceed 80 columns.

print "$_[0]\n";
print "$_[0]\n";
print "$_[0]\n";
print "$_[0]";
my $totlen = length( $_[0] );
my @themsg = split( /\s/, $_[1] );
foreach my $token ( @themsg )
{
$totlen += length( $token ) + 1;
if ( $totlen < 80 )
{
print " $token";
}
else
{
$totlen = length( $_[0] ) + 1 + length( $token ) + 1;
print "\n$_[0] $token";
}
}
print "\n$_[0]\n";
print "$_[0]\n";
print "$_[0]\n";
}

sub pause
{
print "\n\nPress return to continue...";
my $bogus = <STDIN>;
}

sub ucwords
{
my $result=lc shift;
$result =~ s/^(\w)/uc($1)/e;
$result =~ s/([ .,;:+!\"-\(]+)(\w)/$1.uc($2)/ge;
return $result;
}

sub AlloCineParse
{
my $content = $_[0];

# Translate linefeeds
$content =~ s/\015/\012/gm;

# Remove blank lines
$content =~ s|^\s*\012||gm;

# Figure out day offsets
my @now = localtime ();
my $DOW = $now[6];
my %dayoffsets = ();
my $daynum = 0;
foreach my $day ( 'Dim', 'Lun', 'Mar', 'Mer', 'Jeu', 'Ven', 'Sam' )
{
$dayoffsets{ $day } = $daynum - $DOW;
if ( $dayoffsets{ $day } < 0 && !( $daynum < $DOW && $daynum >= 3 ))
{
$dayoffsets{ $day } += 7;
}

$daynum++;
}

my $mode = "";
foreach my $line ( split /\012/, $content )
{
if ( $line =~ /^\[(.+)\]$/ )
{
$mode = $1;
next;
}

if ( $mode eq "SALLES" )
{
my ( $TID, $theatername, $address, $zip, $city ) = split ( /,/, $line );

#translate 's into ,'s
$theatername = s//,/g;
$address = s/~/,/g;

next if ( IgnoringTheater ( $theatername ));

my $theaterinfo = sprintf ( "%s, %s, %s", $address, $zip, $city );

$hTheaters{ $TID }{ "Name" } = $theatername;
$hTheaters{ $TID }{ "Info" } = $theaterinfo;
}
elsif ( $mode eq "SEANCES" )
{
if ( $line =~ /^(\w+)\s*,\s*(\w+)\s*,\s*(.+)\s,(\d)$/ )
{
my $MID = $1;
my $TID = $2;
my $times = $3;
my $lang = $4;

next if ( !exists ( $hTheaters{ $TID }));

my %daytimes = ();

my $lastcnk = "time";
my @incdays = ( 'Dim', 'Lun', 'Mar', 'Mer', 'Jeu', 'Ven', 'Sam' );
my @excdays = ();
my @times = ();
foreach my $cnk ( split ( /[,\s]+/, $times ))
{
if ( $cnk =~ /(Dim)|(Lun)|(Mar)|(Mer)|(Jeu)|(Ven)|(Sam)/i )
{
if ( $lastcnk eq "time" )
{
filltimes ( \%daytimes, \@incdays, \@excdays, \@times );

@incdays = $cnk;

$lastcnk = "dow";
}
elsif ( $lastcnk eq "sauf" )
{
push @excdays, $cnk;
}
else
{
push @incdays, $cnk;
$lastcnk = "dow";
}
}
elsif ( $cnk eq "sauf" )
{
$lastcnk = "sauf";
}
elsif ( $cnk =~ /^\d+/ )
{
if ( $lastcnk eq "sauf" )
{
filltimes ( \%daytimes, \@incdays, \@excdays, \@times );
}

push @times, $cnk;
$lastcnk = "time";
}
elsif ( $cnk eq "sup." )
{
filltimes ( \%daytimes, \@incdays, \@excdays, \@times );

$lastcnk = "time";
}
}

filltimes ( \%daytimes, \@incdays, \@excdays, \@times );

foreach my $day ( keys %daytimes )
{
# Ignore past data
if ( $dayoffsets{ $day } >= 0 )
{
# Add the day, if need be, and correct our local time into gm time.
my @gmtimebits = gmtime ();
my $time = timegm ( 0, 0, 0, $gmtimebits[3], $gmtimebits[4], $gmtimebits[5]);
$time += $dayoffsets{ $day } * ( 60*60*24 );

# If we are running on a Mac, we need to fudge the time and
# the following value will not be zero
my $timefudge = timegm ( 0, 0, 0, 1, 0, 1970 );
$time -= $timefudge;

my $DID = -1;
if ( !exists ( $hTempDates{ $time })) {
$DID = $nDate++;

$hDates{ $DID }{ "Date" } = $time;
$hTempDates{ $time }{ "ID" } = $DID;
}
else {
$DID = $hTempDates{ $time }{ "ID" };
}

my $finalstr = $daytimes{ $day };
if ( $lang == 1 )
{
$finalstr .= " (VO)";
}
elsif ( $lang == 2 )
{
$finalstr .= " (VF)";
}
$daytimes{ $day } = $finalstr;

# Check that this ID combo hasn't been stored already
my $IDID = "_${MID}_${TID}_${DID}_";
if ( !exists ( $hTempShowtimes{ $IDID }))
{
$hTempShowtimes{ $IDID } = 1;

my $SID = -1;
if ( !exists ( $hTempTimeStrings{ $daytimes{ $day }}))
{
$SID = $nTimeString++;

$hTimeStrings{ $SID }{ "String" } = $daytimes{ $day };
$hTempTimeStrings{ $daytimes{ $day } }{ "ID" } = $SID;
}
else
{
$SID = $hTempTimeStrings{ $daytimes{ $day } }{ "ID" };
}

$hShowtimes{ $nShowtime }{ "MID" } = $MID;
$hShowtimes{ $nShowtime }{ "TID" } = $TID;
$hShowtimes{ $nShowtime }{ "DID" } = $DID;
$hShowtimes{ $nShowtime }{ "SID" } = $SID;
$nShowtime++;
}
}
}
}
}
elsif ( $mode eq "FILMS" )
{
#lop off garbage at end of line
$line =~ s/\s*$//;

my ( $MID, $director, $title, $category, $weight, $actor1, $actor2, $actor3, $origtitle ) = split ( /\s*,\s*/, $line );

#translate 's into ,'s
$title = s//,/g;
$origtitle = s/~/,/g;

# Make sure there is showtime data for this movie
foreach my $IDID ( keys %hTempShowtimes )
{
my @bits = split ( /_/, $IDID );
if ( $bits[1] eq $MID )
{
my $moviename = $title;
if ( $origtitle ne "" )
{
$moviename .= " ($origtitle)";
}

$hMovies{ $MID }{ "Name" } = $moviename;
if ( $category eq "AV" )
{
$hMovies{ $MID }{ "Length" } = "Aventure";
}
elsif ( $category eq "CD" )
{
$hMovies{ $MID }{ "Length" } = "Comedie dramatique";
}
elsif ( $category eq "CE" )
{
$hMovies{ $MID }{ "Length" } = "Comedie erotique";
}
elsif ( $category eq "CM" )
{
$hMovies{ $MID }{ "Length" } = "Court metrage";
}
elsif ( $category eq "CO" )
{
$hMovies{ $MID }{ "Length" } = "Comedie";
}
elsif ( $category eq "DA" )
{
$hMovies{ $MID }{ "Length" } = "Dessin anime";
}
elsif ( $category eq "DO" )
{
$hMovies{ $MID }{ "Length" } = "Documentaire";
}
elsif ( $category eq "DR" )
{
$hMovies{ $MID }{ "Length" } = "Drame";
}
elsif ( $category eq "EH" )
{
$hMovies{ $MID }{ "Length" } = "Epouvante horreur";
}
elsif ( $category eq "ER" )
{
$hMovies{ $MID }{ "Length" } = "Erotique";
}
elsif ( $category eq "FE" )
{
$hMovies{ $MID }{ "Length" } = "Festival";
}
elsif ( $category eq "FF" )
{
$hMovies{ $MID }{ "Length" } = "Film fantastique";
}
elsif ( $category eq "FM" )
{
$hMovies{ $MID }{ "Length" } = "Film musical";
}
elsif ( $category eq "GU" )
{
$hMovies{ $MID }{ "Length" } = "Film de guerre";
}
elsif ( $category eq "HI" )
{
$hMovies{ $MID }{ "Length" } = "Film historique";
}
elsif ( $category eq "KA" )
{
$hMovies{ $MID }{ "Length" } = "Karate";
}
elsif ( $category eq "NR" )
{
$hMovies{ $MID }{ "Length" } = "Non reference";
}
elsif ( $category eq "PO" )
{
$hMovies{ $MID }{ "Length" } = "Policier";
}
elsif ( $category eq "WE" )
{
$hMovies{ $MID }{ "Length" } = "Western";
}
elsif ( $category eq "ZZ" )
{
$hMovies{ $MID }{ "Length" } = "Divers";
}

last;
}
}
}
}
}

#### auYahooParse contributed by Duncan Sargeant
#
#

# " (to balance my colouriser :-)

sub auYahooParse
{
my %days = ( 'sunday' => 0,
'monday' => 1,
'tuesday' => 2,
'wednesday' => 3,
'thursday' => 4,
'friday' => 5,
'saturday' => 6,
'sunday' => 7
);

my ($content, $URL) = @_;

# Figure out day offsets
my @now = localtime ();
my $DOW = $now[6];

# Make sure this is a valid page
if ( $content =~ /Nope, sorry, nothing/ ) {
print "This page was unavailable!\n\n";
return;
}

# $content is the list of cinemas in the selected area.
$content =~ /(^.*<li>.*$)/mi;
$content = $1;
my @theaters = split ( /<li>/i, $content );

# Lop off the first chunk, cause it isn't really a theater
shift @theaters;

foreach (@theaters) {
next unless (/^<a href="(.*)\/">(.*)<\/a>/);
my $dir = $1;
my $theatername = $2;

if (IgnoringTheater ($theatername)) {
next;
}

print " Getting theater $theatername...\n";

my $foundtoday = 0;
foreach my $day ('thursday', 'friday', 'saturday', 'sunday', 'monday', 'tuesday', 'wednesday') {

$foundtoday = 1 if ( $days { $day } == $DOW );
next unless $foundtoday;

print " Getting day $day...\n";

$content = grabpage ("$URL/$dir/$day.html");
## theatername is mentioned twice - remove first instance.
next unless $content =~ s/^.*$theatername.*$//m;
## second instance gives us the date.
next unless $content =~ /^.*$theatername(.*)$/m;
my $datestr = $1;
$datestr =~ s/<[^>]*>//g;
$datestr =~ s/\&nbsp\;/ /g;
my ($foo, $date, $monthstr, $year) = split (/\s/, $datestr);
my $month = 0;
foreach ('january', 'february', 'march', 'april', 'may', 'june', 'july', 'august',
'october', 'november', 'december') {
if ($monthstr =~ /$_/i) {
last;
}
$month++;
}

# I think is has been fixed -jrray
#
# ## don't ask me why, but ... -dunc
# #$date++;

my $time = timegm ( 0, 0, 0, $date, $month, $year );

# If we are running on a Mac, we need to fudge the time and
# the following value will not be zero
my $timefudge = timegm ( 0, 0, 0, 1, 0, 1970 );
$time -= $timefudge;

my $DID = -1;
if ( !exists ( $hTempDates{ $time })) {
$DID = $nDate++;

$hDates{ $DID }{ "Date" } = $time;
$hTempDates{ $time }{ "ID" } = $DID;
}
else {
$DID = $hTempDates{ $time }{ "ID" };
}

$content =~ />([^>][^>][^>]+)\n/s;
my $theaterinfo = $1;

my $TID = -1;
if (not exists $hTempTheaters{$theatername}) {
$TID = $nTheater++;
$hTheaters{ $TID }{ "Name" } = $theatername;
$hTempTheaters{ $theatername }{ "ID" } = $TID;
$hTheaters{ $TID }{ "Info" } = $theaterinfo;
}
else {
$TID = $hTempTheaters{ $theatername }{ "ID" };
}

my @movies = split (/<li>/i, $content);
shift @movies;
$movies[$#movies] =~ s/\n.*$//s;

foreach my $movie ( @movies ) {
# Remove the HTML from $movie
$movie =~ s/<[^>]*>//gs;
$movie =~ s/ //gs;

my ($moviename, $showtimes) = split (/ - /, $movie);

my $MID = -1;
if ( !exists ( $hTempMovies{ $moviename })) {
$MID = $nMovie++;
$hMovies{ $MID }{ "Name" } = $moviename;
$hTempMovies{ $moviename }{ "ID" } = $MID;
}
else {
$MID = $hTempMovies{ $moviename }{ "ID" };
}

# Check that this ID combo hasn't been stored already
my $IDID = "_${MID}_${TID}_${DID}_";
if ( !exists ( $hTempShowtimes{ $IDID })) {
$hTempShowtimes{ $IDID } = 1;
chomp $showtimes;
my $SID = -1;
if ( !exists ( $hTempTimeStrings{ $showtimes })) {
$SID = $nTimeString++;
$hTimeStrings{ $SID }{ "String" } = $showtimes;
$hTempTimeStrings{ $showtimes }{ "ID" } = $SID;
}
else {
$SID = $hTempTimeStrings{ $showtimes }{ "ID" };
}

$hShowtimes{ $nShowtime }{ "MID" } = $MID;
$hShowtimes{ $nShowtime }{ "TID" } = $TID;
$hShowtimes{ $nShowtime }{ "DID" } = $DID;
$hShowtimes{ $nShowtime }{ "SID" } = $SID;
$nShowtime++;
}
}
}
}
}

#
#
#### auYahooParse contributed by Duncan Sargeant

sub YahooParse
{
my %months = ( 'January' => 0,
'February' => 1,
'March' => 2,
'April' => 3,
'May' => 4,
'June' => 5,
'July' => 6,
'August' => 7,
'September' => 8,
'October' => 9,
'November' => 10,
'December' => 11
);

my $content = $_[0];

#
# Make sure this is a valid page
#
if ( $content =~ /Nope, sorry, nothing/ )
{
print "This page was unavailable!\n\n";
next;
}

#
# Do some inital cleanup on the whole enchilada
#

# Translate linefeeds
$content =~ s/\015/\012/gm;

# Translate metaspaces into newlines
$content =~ s/ /\012/gs;

# Remove blank lines
$content =~ s|^\s*\012||gm;

# Lop off everything [Legend
$content =~ s/Legend<\/b>.*//s;

#
# Divide the HTML up by the theater token
#
my @theaters = split ( "", $content );

#
# Lop off the first chunk, cause it isn't really a theater
#
my $header = shift @theaters;

#
# Find the date in the first chunk
#
my $datestr;
my $time;
if ( $header =~ /(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)(\w*)\s(\d\d),\s(\d\d\d\d)/s )
{
my $monthstr = $1 . $2;
my $day = $3;
my $year = $4;
my $month=$months{$monthstr};

$time = timegm ( 0, 0, 0, $day, $month, $year );

# If we are running on a Mac, we need to fudge the time and
# the following value will not be zero
my $timefudge = timegm ( 0, 0, 0, 1, 0, 1970 );
$time -= $timefudge;
}

my $DID = -1;
if ( !exists ( $hTempDates{ $time }))
{
$DID = $nDate++;

$hDates{ $DID }{ "Date" } = $time;
$hTempDates{ $time }{ "ID" } = $DID;
}
else
{
$DID = $hTempDates{ $time }{ "ID" };
}

foreach my $theater ( @theaters )
{
( my $theaterinfo, my @movies ) = split ( //, $theater );

# Remove the HTML from theaterinfo
$theaterinfo =~ s/<.*?>//gs;

# Remove "Map It"
$theaterinfo =~ s/Map It//g;

# Remove blank lines
$theaterinfo =~ s|^\s*\012||gm;

( my $theatername, my @theaterextra ) = split ( /\012/, $theaterinfo );

if ( IgnoringTheater ( $theatername ))
{
next;
}

my $TID = -1;
if ( !exists ( $hTempTheaters{ $theatername }))
{
$TID = $nTheater++;

$hTheaters{ $TID }{ "Name" } = $theatername;
$hTempTheaters{ $theatername }{ "ID" } = $TID;

if ( $#theaterextra > 1 && $theaterextra[0] =~ /^Handicapped/ )
{
# Roll the handicapped message around to the back
push ( @theaterextra, shift @theaterextra );
}

$hTheaters{ $TID }{ "Info" } = join ( "\012", @theaterextra );
}
else
{
$TID = $hTempTheaters{ $theatername }{ "ID" };
}

foreach my $movie ( @movies )
{
# Skip theaters that don't have any movie info
if ( $movie =~ /Sorry, we have no info/ )
{
next;
}

( my $movieinfo, my $showtimes ) = split ( "", $movie );

# Remove the HTML from movieinfo
$movieinfo =~ s/<.*?>//gs;

# Remove blank lines
$movieinfo =~ s|^\s*\012||gm;

( my $moviename, my @movieextra ) = split ( /\012/, $movieinfo );

my $MID = -1;
if ( !exists ( $hTempMovies{ $moviename }))
{
$MID = $nMovie++;

#querymovie ( $moviename );

$hMovies{ $MID }{ "Name" } = $moviename;
$hTempMovies{ $moviename }{ "ID" } = $MID;

foreach my $line ( @movieextra )
{
# Attempt to figure out if this line is the rating, or the running time
if ( $line =~ /^\d/ )
{
# First character is a number, then it is probably the length
$hMovies{ $MID }{ "Length" } = $line;
}
else
{
# First character is a letter, then it is probably the rating
$hMovies{ $MID }{ "Rating" } = $line;
}
}
}
else
{
$MID = $hTempMovies{ $moviename }{ "ID" };
}

# Check that this ID combo hasn't been stored already
my $IDID = "_${MID}_${TID}_${DID}_";
if ( !exists ( $hTempShowtimes{ $IDID }))
{
$hTempShowtimes{ $IDID } = 1;

# Remove the HTML from showtimes
$showtimes =~ s/<.*?>//gs;

# Remove blank lines
$showtimes =~ s|^\s*\012||gm;

# Lop of extra garbage at the end
$showtimes =~ s/\[\w.*\].*$//s;

# Remove the trailing linefeed
chomp ( $showtimes );

my $SID = -1;
if ( !exists ( $hTempTimeStrings{ $showtimes }))
{
$SID = $nTimeString++;

$hTimeStrings{ $SID }{ "String" } = $showtimes;
$hTempTimeStrings{ $showtimes }{ "ID" } = $SID;
}
else
{
$SID = $hTempTimeStrings{ $showtimes }{ "ID" };
}

$hShowtimes{ $nShowtime }{ "MID" } = $MID;
$hShowtimes{ $nShowtime }{ "TID" } = $TID;
$hShowtimes{ $nShowtime }{ "DID" } = $DID;
$hShowtimes{ $nShowtime }{ "SID" } = $SID;
$nShowtime++;
}
}
}
}

sub ScootParse
{
my $content = $_[0];
my $Ignoring = 0;

#### GARETH'S SCOOT CODE STARTS HERE ###
# There's also a new function called ucwords() which
# I've included at the end of the file
#
# ---
# $Ignoring stuff mine -- jrray

my %months = ( 'January' => 0,
'February' => 1,
'March' => 2,
'April' => 3,
'May' => 4,
'June' => 5,
'July' => 6,
'August' => 7,
'September' => 8,
'October' => 9,
'November' => 10,
'December' => 11
);

# Translate linefeeds
$content =~ s/\015/\012/gm;

# Translate metaspaces into newlines
$content =~ s/ / /gs;
$content =~ s/ /\012/gs;

# Remove blank lines
$content =~ s|^\s*\012||gm;

my @content=split(/\012/,$content);

my ($theatername,$theaterextra) = ('','');
my ($movie,$showtimes)=('','');
my ($date,$location)=('','');
my ($DID,$TID,$line,$tline) = (-1,-1,'',0);
LINE:foreach $line (@content) {
if (!$location) {
if ($line =~ /r=CINCL[^>]*>([^<]+)/) {
$location=$1;
next LINE;
}
}
if (!$date) {
if ($line =~ /^Valid from \w+, \w+ \d+, \d+ to (\w+), (\w+) (\d+), (\d+)/) {
# Process date line
my ($dayname,$monthstr,$day,$year)=($1,$2,$3,$4);
my $month=$months{$monthstr};
my $time = timegm ( 0, 0, 0, $day, $month, $year );

# If we are running on a Mac, we need to fudge the time and
# the following value will not be zero
my $timefudge = timegm ( 0, 0, 0, 1, 0, 1970 );
$time -= $timefudge;

$DID = -1;
if ( !exists ( $hTempDates{ $time })) {
$DID = $nDate++;

$hDates{ $DID }{ "Date" } = $time;
$hTempDates{ $time }{ "ID" } = $DID;
} else {
$DID = $hTempDates{ $time }{ "ID" };
}
$date=1;
}
next LINE;
}
if ((!$theatername || $tline>5) && (length($line) < 80)) {

if ($line =~ /r=CINOC[^>]*>(.*?)<\//) {
$theatername=ucwords($1);

# If this theater is in our kill file, ignore it -- jrray
my $Ignoring = IgnoringTheater ( $theatername );

$tline=1;
$TID=-1;
if ( !$Ignoring )
{
if (!exists( $hTempTheaters{ $theatername })) {
$TID = $nTheater++;
$hTheaters{ $TID }{ "Name" } = $theatername;
$hTempTheaters{ $theatername }{ "ID" } = $TID;
} else {
$TID = $hTempTheaters{ $theatername }{ "ID" };
}
}
$theaterextra='';
}
next LINE if $tline<6;
}
# There are 8 lines of Cinema info below each cinema name
if ($theatername && $tline<6) {
if ($tline==1 && $line =~ /miles/) {
$line.=" from $location";
}
$theaterextra.=$line."\012";
$tline++;
if ( !$Ignoring )
{
if ($tline>5) {
$hTheaters{ $TID }{ "Info" } = $theaterextra;
}
}
next LINE;
}
if (!$movie && (length($line)>80)) {
if ($line =~ /r=CINOF[^>]+>([^<]+)/) {
$movie=ucwords($1);
if ($movie =~ /^\s*$/ || $movie =~ /NO FILMS SHOW/i) {
$movie='';
}
}
next LINE;
}
if ($movie&&!$showtimes) {
$showtimes=$line;
$showtimes =~ s/^\s+//g; # surpress leading spaces
if ($showtimes =~ /^\s*$/ || !($showtimes =~ /^/)) {
$movie=$showtimes=''; # invalid/empty
next LINE;
}
$showtimes =~ s/<.*?>//gs;
$showtimes=&ucwords($showtimes);
$showtimes =~ s/\W+$//; # Strip trailing punctuation
my $MID = -1;
if ( !$Ignoring )
{
if ( !exists ( $hTempMovies{ $movie })) {
$MID = $nMovie++;
$hMovies{ $MID }{ "Name" } = $movie;
$hTempMovies{ $movie }{ "ID" } = $MID;
} else {
$MID = $hTempMovies{ $movie }{ "ID" };
}
}

#####################
#
# These changes by J Robert Ray

# Get rid of those pesky ,;'s
$showtimes =~ s/,;/;/g;

# Translate ;'s into newlines
$showtimes =~ s/;/\012/g;

# Strip off trailing newlines
chomp $showtimes;

#
#####################

# Check that this ID combo hasn't been stored already
my $IDID = "_${MID}_${TID}_${DID}_";
if ( !$Ignoring )
{
if ( !exists ( $hTempShowtimes{ $IDID })) {
$hTempShowtimes{ $IDID } = 1;
my $SID = -1;
if ( !exists ( $hTempTimeStrings{ $showtimes })) {
$SID = $nTimeString++;

$hTimeStrings{ $SID }{ "String" } = $showtimes;
$hTempTimeStrings{ $showtimes }{ "ID" } = $SID;
} else {
$SID = $hTempTimeStrings{ $showtimes }{ "ID" };
}

$hShowtimes{ $nShowtime }{ "MID" } = $MID;
$hShowtimes{ $nShowtime }{ "TID" } = $TID;
$hShowtimes{ $nShowtime }{ "DID" } = $DID;
$hShowtimes{ $nShowtime }{ "SID" } = $SID;
$nShowtime++;
}
}
$showtimes=$movie='';
}
}
### END OF SCOOT CODE
}

sub IgnoringTheater
{
my $theatername = $_[0];

if ( exists $TheaterIgnore{ $theatername })
{
return $TheaterIgnore{ $theatername };
}
else
{
$TheaterIgnore{ $theatername } = 0;
}

return 0;
}

sub printspaces
{
my $num = $_[0];

for ( my $i = 0; $i < $num; $i++ )
{
print THEATERLIST " ";
}
}

sub querymovie
{
my $title = $_[0];

$title =~ s/\ /\+/g;
$title =~ s/&/%26/g;
$title =~ s/:/%3A/g;

my $URL = "http://us.imdb.com/Tfuzzy?title=" . $title . "&type=fuzzy&sort=chrono&tv=off";

#my $URL = "http://us.imdb.com/Plot?" . $title;

print $URL . "\n";

#my $request = new HTTP::Request ( 'GET', $URL );
}

sub filltimes
{
# Takes in references to the day hash, inc days, excl days, and times.

if ( $#{$_[3]} >= 0 )
{
DAY:foreach my $day ( @{$_[1]})
{
foreach my $unday ( @{$_[2]})
{
next DAY if ( $day eq $unday );
}

if ( exists ( ${_[0]}{ $day }))
{
${$_[0]}{ $day } .= ", ";
}
${$_[0]}{ $day } .= join ( ", ", @{$_[3]} );

my @times = split ( /,\s*/, ${$_[0]}{ $day });
${$_[0]}{ $day } = join ( ", ", sort @times );
}
}

@{$_[1]} = ( 'Dim', 'Lun', 'Mar', 'Mer', 'Jeu', 'Ven', 'Sam' );
@{$_[2]} = ();
@{$_[3]} = ();
}

sub ParseParams
{
my $arg = "";
for ( my $i = 0; $i <= $#ARGV; $i++ )
{
if ( substr ( $ARGV[$i], 0, 1 ) eq "-" )
{
$arg = substr ( $ARGV[$i], 1, length ( $ARGV[$i] ) - 1 );

SWITCH: {
( $arg eq "h" || $arg eq "help" ) && do { PrintUsage (); last SWITCH; };
}
}
else
{
SWITCH: {
$arg eq "d" && do { $ConfigPath = $ARGV[$i]; $arg = ""; last SWITCH; };
}
}
}
}

sub PrintUsage
{
print "USAGE: getdata.pl [-c configpath]\n\n";
print "-c configpath where configpath is path to find getdata.cfg\n";

pause ();
exit 1;
}

Perl Info



Site configuration information for perl 5.00562:

Configured by lwv26 at Sat Oct 16 16:29:03 EDT 1999.

Summary of my perl5 (revision 5.0 version 5 subversion 62) configuration:
  Platform:
    osname=solaris, osvers=2.6, archname=sun4-solaris
    uname='sunos lwv26awu 5.6 generic_105181-16 sun4u sparc sunw,ultra-5_10 '
    config_args=''
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=undef useperlio=undef d_sfio=undef
    use64bits=undef usemultiplicity=undef
  Compiler:
    cc='cc', optimize='-g', gccversion=
    cppflags='-DDEBUGGING -I/usr/ccs/include -I/vol/lwv26ldatae/include -I/projects/gnu/sparc-sun-solaris2.6/include'
    ccflags ='-DDEBUGGING -I/usr/ccs/include -I/vol/lwv26ldatae/include -I/projects/gnu/sparc-sun-solaris2.6/include'
    stdchar='unsigned char', d_stdstdio=define, usevfork=false
    intsize=4, longsize=4, ptrsize=4, doublesize=8
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
    alignbytes=8, usemymalloc=y, prototype=define
  Linker and Libraries:
    ld='cc', ldflags ='-L/usr/ccs/lib -L/vol/lwv26ldatae/lib -L/projects/gnu/sparc-sun-solaris2.6/lib -R/usr/ccs/lib:/vol/lwv26ldatae/lib:/projects/gnu/sparc-sun-solaris2.6/lib'
    libpth=/lib /usr/ccs/lib /vol/lwv26ldatae/lib /projects/gnu/sparc-sun-solaris2.6/lib
    libs=-lsocket -lnsl -lgdbm -ldb -ldl -lm -lc -lcrypt -lsec
    libc=/lib/libc.so, so=so, useshrplib=false, libperl=libperl.a
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags=' '
    cccdlflags='-KPIC', lddlflags='-G -L/usr/ccs/lib -L/vol/lwv26ldatae/lib -L/projects/gnu/sparc-sun-solaris2.6/lib -R/usr/ccs/lib:/vol/lwv26ldatae/lib:/projects/gnu/sparc-sun-solaris2.6/lib'

Locally applied patches:
    


@INC for perl 5.00562:
    /home/lwv26/lib/perl5/
    /projects/sprs_lwv/lib/perl5/
    /vol/lwv26ldatae/lib/perl5/5.006/sun4-solaris
    /vol/lwv26ldatae/lib/perl5/5.006
    /vol/lwv26ldatae/lib/site_perl/5.006/sun4-solaris
    /vol/lwv26ldatae/lib/site_perl
    .


Environment for perl 5.00562:
    HOME=/home/lwv26
    LANG=C
    LANGUAGE (unset)
    LD_LIBRARY_PATH=/lprod/cas/lib:/usr/dt/lib:/usr/openwin/lib:/usr/lib
    LOGDIR (unset)
    PATH=/opt/SUNWspro/bin:/ldatae/bin:/projects/sprs_lwv/sol26/bin:/projects/sprs_lwv/sol26/bin/mime:/projects/sprs_lwv/sol2/bin:/projects/sprs_lwv/bin:/projects/sprs_lwv/bin/mime:/home/lwv26/bin/D.news:/usr/perl5/bin:/projects/gnu/sparc-sun-solaris2.6/bin:/usr/tcl82/sun4/bin:/usr/tcl82/bin:/projects/xopsrc/sun4/bin:/projects/xopsrc/bin:/usr/atria/bin:/projects/intranet/bin:/projects/clearcase/bin:/vol/tclsrcsol/TclPro1.3/solaris-sparc/bin:/ldata2/teTeX/bin/sparc-sun-solaris2.6:/ldata/bin:/home/lwv26/bin/D.aws:/home/lwv26/bin/sol2:/home/lwv26/bin/D.frontend:/home/lwv26/bin/D.ksh:/cas/test/bin/sun4:/projects/sprs_lwv/bin/sol2:/usr/java1.2/bin:/home/lwv26/bin/sun4:/lprod/cas/bin:/usr/local/bin:/usr/dt/bin:/usr/openwin/bin:/bin:/cas/bin/sun4:/cas/abin/sun4:/cas/X11/sun4/bin:/usr/ccs/bin:/uprod/bin:/usr/sbin:/cas/tools/bin/sun4:/cas/X11/sun4/tools/bin:/usr/ucb:/home/lwv26/bin:/cas/tools/pdbin/sun4:/home/lwv26/bin/D.mistypes:/home/lwv26/bin/D.toys:/home/lwv26/bin/D.tools:/projects!
/npd/npdweb/bin-sol2
    PERL5LIB=/home/lwv26/lib/perl5/:/projects/sprs_lwv/lib/perl5/:
    PERLDOC=-t
    PERLLIB=/home/lwv26/lib/perl:/projects/sprs_lwv/lib/perl:
    PERL_BADLANG (unset)
    SHELL=/bin/ksh

-- 
<URL: mailto:lvirden@cas.org> Quote: Pikachu, I choose you!
<*> O- <URL: http://www.purl.org/NET/lvirden/>
Unless explicitly stated to the contrary, nothing in this posting
should be construed as representing my employer's opinions.
-><-

p5pRT · 1999-10-26T07:54:42Z

From [Unknown Contact. See original ticket]

I recompiled perl with -g and here is the stack trace I am getting.

program terminated by signal SEGV (no mapping at the fault address)
Current function is Perl_re_intuit_start
371 CHR_SVLEN(prog->check_substr) +
(SvTAIL(prog->check_substr) != 0);
(dbx 1) where
=>[1] Perl_re_intuit_start(prog = 0x420488, sv = 0x41e504, strpos =
0x5ebc84 "A HRef="#T14">Cinemark Movies 10 - Westpointe Plaza</A>\n-\n<A
HRef="#T15">GC Westland 8</A>\n-\n<A HRef="#T16">Regal Georgesville
Square 16</A>\n-\n<A HRef="#T17">Marcus Cinema & IMAX Theatre -
Crosswoods Center</A>\n-\n<A HRef="#T18">Cinemark Movies 12 - Market at
Mill Run</A>\n-\n<A HRef="#T19">AMC Dublin Village 18</A>\n-\n<A
HRef="#T20">Hollywood - Indian Mound 11</A>\n-\n<A HRef="#T21">Hollywood
- Newark 4</A>\n-\n<A HRef="#T22">Regal River Valley
10</A> \n<tr><td colspan=2 height=4></td></tr>\n\n\n\n<tr><td
al" ..., strend = 0x600c14 "", flags = 24U, data = (nil)), line 371 in
"regexec.c"
[2] Perl_regexec_flags(prog = 0x420488, stringarg = 0x5eb9f1
"</td></tr>\n<tr><td colspan=2>\n<A HRef="#T0">AMC Eastland
Centre 8</A>\n-\n<A HRef="#T1">Silver Cinemas - Brice Outlet
Mall</A>\n-\n<A HRef="#T2">Marcus Cinema Pickerington</A>\n-\n<A
HRef="#T3">AMC Easton Town Center 30</A>\n-\n<A HRef="#T4">Drexel
Theatre</A>\n-\n<A HRef="#T5">Cinemark Movies 16 - Gahanna</A>\n-\n<A
HRef="#T6">Studio 35 Cinema</A>\n-\n<A HRef="#T7">AMC Lennox Town Center
24</A>\n-\n<A HRef="#T8">Drexel Grandview</A>\n-\n<A HRef="#T9">GC
Northland 8</A>\n-\n<A HRef="#T10">AMC Westerville 6</A>\n-\n<A HRef"
..., strend = 0x600c14 "", strbeg = 0x5eac08
"<html>\n<head>\n<title>Yahoo! Movies -
Showtimes</title>\n</head>\n<body>\n<A
Name="top">\n</A>\n<center>\n <Map Name="map">\n <area
shape=rect coords="13,0,63,58" \n
href="http://www.yahoo.com">\n <area shape=rect
coords="71,0,117,58" \n
href="http://my.yahoo.com">\n <area shape=rect
coords="348,0,387,58"\n
href="http://www.yahoo.com/docs/info/help.html">\n <area
shape=rect coords="396,0,450,58" \n
href="http://www.yahoo.com/docs/family/m" ..., minend = 0, sv =
0x41e504, data = (nil), flags = 24U), line 807 in "regexec.c"
[3] Perl_pp_subst(), line 1777 in "pp_hot.c"
[4] Perl_runops_debug(), line 51 in "run.c"
[5] S_run_body(args = 0xefffd6b4), line 1080 in "perl.c"
[6] Perl_vdefault_protect(pcur_env = 0xefffd6d4, excpt = 0xefffd734,
body = 0x2f060 = &`perl`perl.c`S_run_body(va_list args), args =
0xefffd654), line 45 in "scope.c"
[7] Perl_default_protect(pcur_env = 0xefffd6d4, excpt = 0xefffd734,
body = 0x2f060 = &`perl`perl.c`S_run_body(va_list args), ...), line 26
in "scope.c"
[8] perl_run(my_perl = 0x225c08), line 1018 in "perl.c"
[9] main(argc = 2, argv = 0xefffd80c, env = 0xefffd818), line 53 in
"perlmain.c"
(dbx 2)
--
<URL: mailto:lvirden@cas.org> Quote: Pikachu, I choose you!
<*> O- <URL: http://www.purl.org/NET/lvirden/>
Unless explicitly stated to the contrary, nothing in this posting
should be construed as representing my employer's opinions.
-><-

p5pRT · 1999-10-26T11:17:08Z

From [Unknown Contact. See original ticket]

Larry W. Virden writes:

I am getting a core dump today from perl. I'm uncertain what to send along.
Right now, my perl isn't compiled with -g - is there a way that I can
recompile with -g without having to go thru all the Configure prompts?

Edit "cflags" file. I have

#optdebug='' # ensure -g used if building a -DDEBUGGING libperl
optdebug='-g -Dregister=' # ensure -g used if building a -DDEBUGGING libperl

$ gdb $(whence perl) core

Well, having something less than 1500+ lines long script would be
helpful too.

Ilya

p5pRT · 1999-10-26T11:29:18Z

From [Unknown Contact. See original ticket]

Larry W. Virden writes:

Current function is Perl_re_intuit_start
371 CHR_SVLEN(prog->check_substr) +
(SvTAIL(prog->check_substr) != 0);

And may I ask what is the reason for segfault? What is the contents
of prog->check_substr? Keep in mind

#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))

and I suspect you do not use utf8, right?

(dbx 1) where
=>[1] Perl_re_intuit_start(prog = 0x420488, sv = 0x41e504, strpos =
0x5ebc84 "A HRef="#T14">Cinemark Movies 10 - Westpointe Plaza</A>\n-\n<A
HRef="#T15">GC Westland 8</A>\n-\n<A HRef="#T16">Regal Georgesville
Square 16</A>\n-\n<A HRef="#T17">Marcus Cinema & IMAX Theatre -
Crosswoods Center</A>\n-\n<A HRef="#T18">Cinemark Movies 12 - Market at
Mill Run</A>\n-\n<A HRef="#T19">AMC Dublin Village 18</A>\n-\n<A
HRef="#T20">Hollywood - Indian Mound 11</A>\n-\n<A HRef="#T21">Hollywood
- Newark 4</A>\n-\n<A HRef="#T22">Regal River Valley
10</A> \n<tr><td colspan=2 height=4></td></tr>\n\n\n\n<tr><td
al" ..., strend = 0x600c14 "", flags = 24U, data = (nil)), line 371 in
"regexec.c"

Hey, I have seen this string (rendered ;-) yesterday! How did you
happen too get it?

Ilya

p5pRT · 1999-10-26T11:36:04Z

From [Unknown Contact. See original ticket]

From: Ilya Zakharevich <ilya@math.ohio-state.edu>

Larry W. Virden writes:
> Current function is Perl_re_intuit_start
> 371 CHR_SVLEN(prog->check_substr) +
> (SvTAIL(prog->check_substr) != 0);

And may I ask what is the reason for segfault? What is the
contents
of prog->check_substr? Keep in mind

#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))

and I suspect you do not use utf8, right?

Current function is Perl_re_intuit_start
371 CHR_SVLEN(prog->check_substr) +
(SvTAIL(prog->check_substr) != 0);
(dbx 1) print prog->check_substr
dbx: can't find field "check_substr" in "*(prog)"
(dbx 2) print UTF
dbx: "UTF" is not defined in the scope
`perl`regexec.c`Perl_re_intuit_start`

dbx: see `help scope' for details
(dbx 3) print sv
sv = 0x41e504
(dbx 4) print *sv
*sv = {
sv_any = 0x5aeb08
sv_refcnt = 1U
sv_flags = 67372295U
}
(dbx 5) print SvCUR(sv)
dbx: "SvCUR" is not defined in the scope
`perl`regexec.c`Perl_re_intuit_start`

Unfortunately, I'm not familiar enough with Perl's internals to
figure out how to dig out the real info here...

--
Larry W. Virden <URL: mailto:lvirden@cas.org> Windows is not the
answer, but
<URL: http://www.purl.org/NET/lvirden/> the question. No
is the answer.
Unless explicitly stated to the contrary, nothing in this posting
should be construed as representing my employer's opinions.

p5pRT · 1999-10-26T12:03:44Z

From [Unknown Contact. See original ticket]

On Tue, Oct 26, 1999 at 02:35:01PM -0400, Larry W. Virden wrote:

Current function is Perl_re_intuit_start
371 CHR_SVLEN(prog->check_substr) +
(SvTAIL(prog->check_substr) != 0);
(dbx 1) print prog->check_substr
dbx: can't find field "check_substr" in "*(prog)"

Well, it is not rocket science to resolve macros (at least if you run
'make etags' and use imenu-go.el in emacs).

#define check_substr substrs->data[2].substr
#define check_offset_min substrs->data[2].min_offset
#define check_offset_max substrs->data[2].max_offset

(dbx 5) print SvCUR(sv)
dbx: "SvCUR" is not defined in the scope

Well, I think you know it already. *((GV*)sv)->sv_any is the simplest
way to access these guys I know.

Ilya

p5pRT · 1999-10-26T12:07:58Z

From [Unknown Contact. See original ticket]

From: Ilya Zakharevich <ilya@math.ohio-state.edu>

Well, I think you know it already. *((GV*)sv)->sv_any is the
simplest
way to access these guys I know.

print *((GV*)sv)->sv_any
*((struct gv *) sv)->sv_any = {
xpv_pv = 0x5eac08 "<html>\n<head>\n<title>Yahoo! Movies
- Showtimes</title>\n</head>\n<body>\n<A
Name="top">\n</A>\n<center>\n <Map Name="map">\n
<area shape=rect coords="13,0,63,58" \n
href="http://www.yahoo.com">\n <area shape=rect
coords="71,0,117,58" \n href="http://my.yahoo.com">\n
<area shape=rect coords="348,0,387,58"\n
href="http://www.yahoo.com/docs/info/help.html">\n
<area shape=rect coords="396,0,450,58" \n
href="http://www.yahoo.com/docs/family/m" ...
xpv_cur = 90124U
xpv_len = 97550U
xiv_iv = 0
xnv_nv = 0.0
xmg_magic = (nil)
xmg_stash = (nil)
xgv_gp = 0x5c5588
xgv_name = (nil)
xgv_namelen = 6U
xgv_stash = (nil)
xgv_flags = '\0'
}

--
Larry W. Virden <URL: mailto:lvirden@cas.org> Windows is not the
answer, but
<URL: http://www.purl.org/NET/lvirden/> the question. No
is the answer.
Unless explicitly stated to the contrary, nothing in this posting
should be construed as representing my employer's opinions.

p5pRT · 1999-10-26T12:11:53Z

From [Unknown Contact. See original ticket]

Larry W. Virden writes:

print *((GV*)sv)->sv_any

This is all pretty nice, but I want to know why *segfault* happens.
The segfault line does not mention sv at all. Sorry for not
mentioning it upfront.

Ilya

p5pRT · 1999-11-01T15:14:19Z

From [Unknown Contact. See original ticket]

Larry W. Virden writes:

I am getting a core dump today from perl. I'm uncertain what to send along.
Right now, my perl isn't compiled with -g - is there a way that I can
recompile with -g without having to go thru all the Configure prompts?

This is a plug only. It fixes a bug, but uncovers yet another
pessimization in the optimizer...

Enjoy,
Ilya

Inline Patch

--- ./t/op/pat.t~	Tue Oct  5 23:20:31 1999
+++ ./t/op/pat.t	Mon Nov  1 18:08:47 1999
@@ -4,7 +4,7 @@
 # the format supported by op/regexp.t.  If you want to add a test
 # that does fit that format, add it to op/re_tests, not here.
 
-print "1..193\n";
+print "1..194\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -891,5 +891,10 @@ $test++;
 $text = "aaXbXcc";
 pos($text)=0;
 $text =~ /\GXb*X/g and print 'not ';
+print "ok $test\n";
+$test++;
+
+$text = "xA\n" x 500;
+$text =~ /^\s*A/m and print 'not ';
 print "ok $test\n";
 $test++;
--- ./regexec.c~	Sun Oct 10 15:25:52 1999
+++ ./regexec.c	Mon Nov  1 18:02:03 1999
@@ -642,6 +642,9 @@ Perl_re_intuit_start(pTHX_ regexp *prog,
 	    prog->check_substr = Nullsv;	/* disable */
 	    prog->float_substr = Nullsv;	/* clear */
 	    s = strpos;
+	    /* XXXX This is a remnant of the old implementation.  It
+	            looks wasteful, since now INTUIT can use many
+	            other heuristics too. */
 	    prog->reganch &= ~RE_USE_INTUIT;
 	}
 	else
@@ -804,9 +807,13 @@ Perl_regexec_flags(pTHX_ register regexp
 		  after_try:
 		    if (s >= end)
 			goto phooey;
-		    s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
-		    if (!s)
-			goto phooey;
+		    if (prog->reganch & RE_USE_INTUIT) {
+			s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
+			if (!s)
+			    goto phooey;
+		    }
+		    else
+			s++;
 		}		
 	    } else {
 		if (s > startpos)

p5pRT · 1999-11-02T03:48:30Z

From [Unknown Contact. See original ticket]

Thank you for the patch. Unfortunately, after applying that patch and
running a make test on perl 5.005_62, I get:

pragma/warnings.....PROG:
# op.c
$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # known scalar leak
use warnings 'unsafe' ;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
@a =~ /abc/ ;
@a =~ s/a/b/ ;
@a =~ tr/a/b/ ;
@$b =~ /abc/ ;
@$b =~ s/a/b/ ;
@$b =~ tr/a/b/ ;
%a =~ /abc/ ;
%a =~ s/a/b/ ;
%a =~ tr/a/b/ ;
%$c =~ /abc/ ;
%$c =~ s/a/b/ ;
%$c =~ tr/a/b/ ;
{
no warnings 'unsafe' ;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
@a =~ /abc/ ;
@a =~ s/a/b/ ;
@a =~ tr/a/b/ ;
@$b =~ /abc/ ;
@$b =~ s/a/b/ ;
@$b =~ tr/a/b/ ;
%a =~ /abc/ ;
%a =~ s/a/b/ ;
%a =~ tr/a/b/ ;
%$c =~ /abc/ ;
%$c =~ s/a/b/ ;
%$c =~ tr/a/b/ ;
}
EXPECTED:
Applying pattern match (m//) to @array will act on scalar(@array) at - line 5.
Applying substitution (s///) to @array will act on scalar(@array) at - line 6.
Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;"
Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7.
Applying pattern match (m//) to @array will act on scalar(@array) at - line 8.
Applying substitution (s///) to @array will act on scalar(@array) at - line 9.
Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10.
Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11.
Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12.
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13.
Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14.
Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15.
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
BEGIN not safe after errors--compilation aborted at - line 18.
GOT:
Applying pattern match (m//) to @array will act on scalar(@array) at - line 5.
Applying substitution (s///) to @array will act on scalar(@array) at - line 6.
Can't modify private array in substitution (s///) at - line 6, near "s/a/b/ ;"
Applying transliteration (tr///) to @array will act on scalar(@array) at - line 7.
Applying pattern match (m//) to @array will act on scalar(@array) at - line 8.
Applying substitution (s///) to @array will act on scalar(@array) at - line 9.
Applying transliteration (tr///) to @array will act on scalar(@array) at - line 10.
Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 11.
Applying substitution (s///) to %hash will act on scalar(%hash) at - line 12.
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 13.
Applying pattern match (m//) to %hash will act on scalar(%hash) at - line 14.
Applying substitution (s///) to %hash will act on scalar(%hash) at - line 15.
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
BEGIN not safe after errors--compilation aborted at - line 18.
Scalars leaked: 1
FAILED at test 160
--
Larry W. Virden <URL: mailto:lvirden@cas.org>
<URL: http://www.purl.org/NET/lvirden/> <*> O-
Unless explicitly stated to the contrary, nothing in this posting should
be construed as representing my employer's opinions.
-><-

p5pRT · 1999-11-02T11:43:55Z

From [Unknown Contact. See original ticket]

On Tue, Nov 02, 1999 at 06:47:57AM -0500, Larry W. Virden wrote:

Thank you for the patch. Unfortunately, after applying that patch and
running a make test on perl 5.005_62, I get:

pragma/warnings.....PROG:
# op.c
$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # known scalar leak
use warnings 'unsafe' ;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
@a =~ /abc/ ;
EXPECTED:
...
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
BEGIN not safe after errors--compilation aborted at - line 18.
GOT:
...
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
BEGIN not safe after errors--compilation aborted at - line 18.
Scalars leaked: 1
FAILED at test 160

Was not that seen before? I do not get this warning. Are you running
with PERL_DESTRUCT_LEVEL > 3?

Ilya

p5pRT · 1999-11-02T12:38:33Z

From [Unknown Contact. See original ticket]

Re: was the error seen before?

No, this is the first time I have seen this error.

Re: am I running with PERL_DESTRUCT_LEVEL > 3?

I have no such environment variable set - does the make test set
one?

--
Larry W. Virden <URL: mailto:lvirden@cas.org> Windows is not the
answer, but
<URL: http://www.purl.org/NET/lvirden/> the question. No
is the answer.
Unless explicitly stated to the contrary, nothing in this posting
should be construed as representing my employer's opinions.

p5pRT · 1999-11-02T14:16:38Z

From [Unknown Contact. See original ticket]

On Tue, Nov 02, 1999 at 03:37:24PM -0500, Larry W. Virden wrote:

Re: was the error seen before?

No, this is the first time I have seen this error.

On p5p?

Re: am I running with PERL_DESTRUCT_LEVEL > 3?

I have no such environment variable set - does the make test set
one?

It is set to 2 if not defined. The additional message "Scalars
leaked" which you see indicates that PERL_DESTRUCT_LEVEL > 3 - which
it should not be.

Ilya

p5pRT · 1999-11-02T15:38:48Z

From [Unknown Contact. See original ticket]

On Nov 2, 17:16, Ilya Zakharevich wrote:
} Subject: Re: [ID 19991026.001] perl segmentation fault report
--> On Tue, Nov 02, 1999 at 03:37:24PM -0500, Larry W. Virden wrote:
--> > Re: was the error seen before?
--> >
--> > No, this is the first time I have seen this error.
-->
--> On p5p?

I've never seen this error in person or on p5p <smile>...

--> > Re: am I running with PERL_DESTRUCT_LEVEL > 3?
--> >
--> > I have no such environment variable set - does the make test set
--> > one?
-->
--> It is set to 2 if not defined. The additional message "Scalars
--> leaked" which you see indicates that PERL_DESTRUCT_LEVEL > 3 - which
--> it should not be.

Interesting...

--
<URL: mailto:lvirden@cas.org> Quote: Pikachu, I choose you!
<*> O- <URL: http://www.purl.org/NET/lvirden/>
Unless explicitly stated to the contrary, nothing in this posting
should be construed as representing my employer's opinions.
-><-

p5pRT · 1999-11-18T08:04:56Z

From [Unknown Contact. See original ticket]

I'm continuing to see this segmentation fault. The last suggestion from
the list was that I had PERL_DESTRUCT_LEVEL set to a value greater
than 2. But I don't have any such variable set in my shell variable
environment. Is there someplace within perl's configuration environment
where this might be set?
--
Larry W. Virden <URL: mailto:lvirden@cas.org>
<URL: http://www.purl.org/NET/lvirden/> <*> O-
Unless explicitly stated to the contrary, nothing in this posting should
be construed as representing my employer's opinions.
-><-

p5pRT · 1999-11-18T09:34:54Z

From @andk

On Thu, 18 Nov 1999 11:04:25 -0500 (EST), "Larry W. Virden" <lvirden@cas.org> said:

I'm continuing to see this segmentation fault. The last suggestion from
the list was that I had PERL_DESTRUCT_LEVEL set to a value greater
than 2. But I don't have any such variable set in my shell variable
environment. Is there someplace within perl's configuration environment
where this might be set?

Ilya said, that what you saw could typically only be seen with
PERL_DESTRUCT_LEVEL > 2. But this doesn't mean, that somebody actually
set it intentionally to that value. It's just as well possible that
some storage area became currupted and accidentally changed the value
while simultaneously the whole running program became unusable.

--
andreas

p5pRT · 1999-11-18T10:34:41Z

From [Unknown Contact. See original ticket]

Andreas J. Koenig writes:

On Thu, 18 Nov 1999 11:04:25 -0500 (EST), "Larry W. Virden" <lvirden@cas.org> said:

I'm continuing to see this segmentation fault. The last suggestion from
the list was that I had PERL_DESTRUCT_LEVEL set to a value greater
than 2. But I don't have any such variable set in my shell variable
environment. Is there someplace within perl's configuration environment
where this might be set?

Ilya said, that what you saw could typically only be seen with
PERL_DESTRUCT_LEVEL > 2. But this doesn't mean, that somebody actually
set it intentionally to that value. It's just as well possible that
some storage area became currupted and accidentally changed the value
while simultaneously the whole running program became unusable.

Nope. The whole running program is usable. "Scalar leaked:" message
is the *only* difference which Larry could see.

Ilya

p5pRT · 1999-11-18T11:10:47Z

From @gsar

On Thu, 18 Nov 1999 11:04:25 EST, "Larry W. Virden" wrote:

I'm continuing to see this segmentation fault. The last suggestion from
the list was that I had PERL_DESTRUCT_LEVEL set to a value greater
than 2. But I don't have any such variable set in my shell variable
environment. Is there someplace within perl's configuration environment
where this might be set?

The test harness enables PERL_DESTRUCT_LEVEL for all tests not
known to leak scalars due to compile-time failures. If you're
getting a test failure due to "Scalars Leaked", it means there
is a new scalar leak somewhere.

Sarathy
gsar@ActiveState.com

p5pRT · 1999-11-18T11:13:44Z

From [Unknown Contact. See original ticket]

Gurusamy Sarathy writes:

I'm continuing to see this segmentation fault. The last suggestion from
the list was that I had PERL_DESTRUCT_LEVEL set to a value greater
than 2. But I don't have any such variable set in my shell variable
environment. Is there someplace within perl's configuration environment
where this might be set?

The test harness enables PERL_DESTRUCT_LEVEL for all tests not
known to leak scalars due to compile-time failures. If you're
getting a test failure due to "Scalars Leaked", it means there
is a new scalar leak somewhere.

Nope. The test in question *already has* "we have a known leak" clause.

Ilya

p5pRT · 1999-11-18T11:27:12Z

From @gsar

On Thu, 18 Nov 1999 14:13:36 EST, Ilya Zakharevich wrote:

Gurusamy Sarathy writes:

I'm continuing to see this segmentation fault. The last suggestion from
the list was that I had PERL_DESTRUCT_LEVEL set to a value greater
than 2. But I don't have any such variable set in my shell variable
environment. Is there someplace within perl's configuration environment
where this might be set?

The test harness enables PERL_DESTRUCT_LEVEL for all tests not
known to leak scalars due to compile-time failures. If you're
getting a test failure due to "Scalars Leaked", it means there
is a new scalar leak somewhere.

Nope. The test in question *already has* "we have a known leak" clause.

Is the "we have a known leak" clause in a BEGIN block? That would
make a difference if the test quits due to errors during compilation.

Sarathy
gsar@ActiveState.com

p5pRT · 1999-11-18T11:31:54Z

From [Unknown Contact. See original ticket]

On Thu, Nov 18, 1999 at 11:33:33AM -0800, Gurusamy Sarathy wrote:

Nope. The test in question *already has* "we have a known leak" clause.

Is the "we have a known leak" clause in a BEGIN block? That would
make a difference if the test quits due to errors during compilation.

IIRC it was a the misc test failing during compilation indeed. But
why would be a "leak" clause there if it was not in a BEGIN block?

Ilya

p5pRT closed this as completed Nov 28, 2003

p5pRT added Severity Medium distro-Solaris type-library labels Oct 18, 2019

p5pRT mentioned this issue Oct 19, 2019

Program terminated with signal 11, Segmentation fault. #12469

Closed

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

perl segmentation fault report #788

perl segmentation fault report #788

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

p5pRT commented Nov 1, 1999

p5pRT commented Nov 2, 1999

p5pRT commented Nov 2, 1999

p5pRT commented Nov 2, 1999

p5pRT commented Nov 2, 1999

p5pRT commented Nov 2, 1999

p5pRT commented Nov 18, 1999

p5pRT commented Nov 18, 1999

p5pRT commented Nov 18, 1999

p5pRT commented Nov 18, 1999

p5pRT commented Nov 18, 1999

p5pRT commented Nov 18, 1999

p5pRT commented Nov 18, 1999

perl segmentation fault report #788

perl segmentation fault report #788

Comments

p5pRT commented Oct 26, 1999

p5pRT commented Oct 26, 1999

From lvirden@cas.org

p5pRT commented Oct 26, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Oct 26, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Oct 26, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Oct 26, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Oct 26, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Oct 26, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Oct 26, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 1, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 2, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 2, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 2, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 2, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 2, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 18, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 18, 1999

From @andk

p5pRT commented Nov 18, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 18, 1999

From @gsar

p5pRT commented Nov 18, 1999

From [Unknown Contact. See original ticket]

p5pRT commented Nov 18, 1999

From @gsar

p5pRT commented Nov 18, 1999

From [Unknown Contact. See original ticket]