# -*- perl -*-
# $Id: errorlib.in,v 1.40 2003/08/30 00:15:15 cjwatson Exp $

use Mail::Address;

sub F_SETLK { 6; } sub F_WRLCK{ 1; }
$flockstruct= 'sslll'; # And there ought to be something for this too.

sub get_hashname {
    return "" if ( $_[ 0 ] < 0 );
    return sprintf "%02d", $_[ 0 ] % 100;
}

sub unlockreadbugmerge {
    local ($rv) = @_;
    &unfilelock if $rv >= 2;
    &unfilelock if $rv >= 1;
}

sub lockreadbugmerge {
    local ($lref, $location) = @_;
    local $data;
    if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); }
    if (!length($data{mergedwith})) { return ( 1, $data ); }
    &unfilelock;
    &filelock('lock/merge');
    if (!&lockreadbug($lref, $location)) { &unfilelock; return ( 0, undef ); }
    return ( 2, $data );
}

sub getbuglocation {
    my ( $bugnum, $ext ) = @_;
    my $archdir = sprintf "%02d", $bugnum % 100;
    return 'archive' if ( -r "$gSpoolDir/archive/$archdir/$bugnum.$ext" );
    return 'db-h' if ( -r "$gSpoolDir/db-h/$archdir/$bugnum.$ext" );
    return 'db' if ( -r "$gSpoolDir/db/$bugnum.$ext" );
    return undef;
}

sub getlocationpath {
    my ($location) = @_;
    if ($location eq 'archive') {
        return "$gSpoolDir/archive";
    } elsif ($location eq 'db') {
        return "$gSpoolDir/db";
    } else {
        return "$gSpoolDir/db-h";
    }
}

sub getbugcomponent {
    my ($bugnum, $ext, $location) = @_;

    unless (defined $location) {
	$location = getbuglocation($bugnum, $ext);
	# Default to non-archived bugs only for now; CGI scripts want
	# archived bugs but most of the backend scripts don't. For now,
	# anything that is prepared to accept archived bugs should call
	# getbuglocation() directly first.
	return undef if defined $location and
			($location ne 'db' and $location ne 'db-h');
    }
    my $dir = getlocationpath($location);
    return undef unless $dir;
    if ($location eq 'db') {
	return "$dir/$bugnum.$ext";
    } else {
	my $hash = get_hashname($bugnum);
	return "$dir/$hash/$bugnum.$ext";
    }
}

my @v1fieldorder = qw(originator date subject msgid package
                      keywords done forwarded mergedwith severity);

my %fields = (originator => 'submitter',
              date => 'date',
              subject => 'subject',
              msgid => 'message-id',
              'package' => 'package',
              keywords => 'tags',
              done => 'done',
              forwarded => 'forwarded-to',
              mergedwith => 'merged-with',
              severity => 'severity',
              owner => 'owner',
             );

sub readbug {
    my ($lref, $location) = @_;
    my $status = getbugcomponent($lref, 'summary', $location);
    return undef unless defined $status;
    if (!open(S,$status)) { return undef; }

    my %data;
    my @lines;
    my $version = 2;
    local $_;

    while (<S>) {
        chomp;
        push @lines, $_;
        $version = $1 if /^Format-Version: ([0-9]+)/i;
    }

    # Version 2 is the latest format version currently supported.
    return undef if $version > 2;

    my %namemap = reverse %fields;
    for my $line (@lines) {
        if ($line =~ /(\S+?): (.*)/) {
            my ($name, $value) = (lc $1, $2);
            $data{$namemap{$name}} = $value if exists $namemap{$name};
        }
    }
    for my $field (keys %fields) {
        $data{$field} = '' unless exists $data{$field};
    }

    close(S);

    $data{severity} = 'normal' if $data{severity} eq '';

    return \%data;
}

sub lockreadbug {
    local ($lref, $location) = @_;
    &filelock("lock/$lref");
    my $data = readbug($lref, $location);
    &unfilelock unless defined $data;
    return $data;
}

sub makestatus {
    my $data = shift;
    my $version = shift;
    $version = 2 unless defined $version;

    my $contents = '';

    if ($version == 1) {
        for my $field (@v1fieldorder) {
            if (exists $data->{$field}) {
                $contents .= "$data->{$field}\n";
            } else {
                $contents .= "\n";
            }
        }
    } elsif ($version == 2) {
        # Version 2. Add a file format version number for the sake of
        # further extensibility in the future.
        $contents .= "Format-Version: 2\n";
        for my $field (keys %fields) {
            if (exists $data->{$field} and $data->{$field} ne '') {
                # Output field names in proper case, e.g. 'Merged-With'.
                my $properfield = $fields{$field};
                $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
                $contents .= "$properfield: $data->{$field}\n";
            }
        }
    }

    return $contents;
}

sub writebug {
    my ($ref, $data, $location, $minversion, $disablebughook) = @_;
    my $change;

    my %outputs = (1 => 'status', 2 => 'summary');
    for my $version (keys %outputs) {
        next if defined $minversion and $version < $minversion;
        my $status = getbugcomponent($ref, $outputs{$version}, $location);
        &quit("can't find location for $ref") unless defined $status;
        open(S,"> $status.new") || &quit("opening $status.new: $!");
        print(S makestatus($data, $version)) ||
            &quit("writing $status.new: $!");
        close(S) || &quit("closing $status.new: $!");
        if (-e $status) {
            $change = 'change';
        } else {
            $change = 'new';
        }
        rename("$status.new",$status) || &quit("installing new $status: $!");
    }

    # $disablebughook is a bit of a hack to let format migration scripts use
    # this function rather than having to duplicate it themselves.
    &bughook($change,$ref,$data) unless $disablebughook;
}

sub unlockwritebug {
    writebug(@_);
    &unfilelock;
}

sub filelock {
    # NB - NOT COMPATIBLE WITH `with-lock'
    local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
    $flockpushno= $#filelocks+1;
    $count= 10; $errors= '';
    for (;;) {
        $evalstring= "
            open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
            \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
                ($] >= 5.000 ? "
            fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
            \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
                 && die \"syscall fcntl setlk: \$!\";") ."
            (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
            (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
            join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
            1;
        ";
        last if eval $evalstring;
        $errors .= $@;
        eval "close(FLOCK$flockpushno);";
        if (--$count <=0) {
            $errors =~ s/\n+$//;
            &quit("failed to get lock on file $lockfile: $errors // $evalstring");
        }
        sleep 10;
    }
    push(@cleanups,'unfilelock');
    push(@filelocks,$lockfile);
}

sub unfilelock {
    if (@filelocks == 0) {
        warn "unfilelock called with no active filelocks!\n";
        return;
    }
    local ($lockfile) = pop(@filelocks);
    pop(@cleanups);
    eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!";
    unlink($lockfile) || warn "failed to remove lock file $lockfile: $!";
}

sub quit {
    print DEBUG "quitting >$_[0]<\n";
    local ($u);
    while ($u= $cleanups[$#cleanups]) { &$u; }
    die "*** $_[0]\n";
}

%saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');

sub sani {
    local ($in) = @_;
    local ($out);
    while ($in =~ m/[<>&"]/) {
        $out.= $`. '&'. $saniarray{$&}. ';';
        $in=$';
    }
    $out.= $in;
    $out;
}

sub update_realtime {
	my ($file, $bug, $new) = @_;

	# update realtime index.db

	open(IDXDB, "<$file") or die "Couldn't open $file";
	open(IDXNEW, ">$file.new");

	my $line;
	my @line;
	while($line = <IDXDB>) {
		@line = split /\s/, $line;
		last if ($line[1] >= $bug);
		print IDXNEW $line;
		$line = "";
	}

	if ($new eq "NOCHANGE") {
		print IDXNEW $line if ($line ne "" && $line[1] == $ref);
	} elsif ($new eq "REMOVE") {
		0;
	} else {
		print IDXNEW $new;
	}
	if ($line ne "" && $line[1] > $bug) {
		print IDXNEW $line;
		$line = "";
	}

	print IDXNEW while(<IDXDB>);

	close(IDXNEW);
	close(IDXDB);

	rename("$file.new", $file);

	return $line;
}

sub bughook_archive {
	my $ref = shift;
	&filelock("debbugs.trace.lock");
	&appendfile("debbugs.trace","archive $ref\n");
	my $line = update_realtime(
		"$gSpoolDir/index.db.realtime", 
		$ref,
		"REMOVE");
	update_realtime("$gSpoolDir/index.archive.realtime",
		$ref, $line);
	&unfilelock;
}	

sub bughook {
	my ( $type, $ref, $data ) = @_;
	&filelock("debbugs.trace.lock");

	&appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));

	my $whendone = "open";
	my $severity = $gDefaultSeverity;
	(my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
	$pkglist =~ s/^,+//;
	$pkglist =~ s/,+$//;
	$whendone = "forwarded" if length $data->{forwarded};
	$whendone = "done" if length $data->{done};
	$severity = $data->{severity} if length $data->{severity};

	my $k = sprintf "%s %d %d %s [%s] %s %s\n",
			$pkglist, $ref, $data->{date}, $whendone,
			$data->{originator}, $severity, $data->{keywords};

	update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);

	&unfilelock;
}

sub appendfile {
	my $file = shift;
	if (!open(AP,">>$file")) {
		print DEBUG "failed open log<\n";
		print DEBUG "failed open log err $!<\n";
		&quit("opening $file (appendfile): $!");
	}
	print(AP @_) || &quit("writing $file (appendfile): $!");
	close(AP) || &quit("closing $file (appendfile): $!");
}

sub getmailbody {
	my $entity = shift;
	my $type = $entity->effective_type;
	if ($type eq 'text/plain' or
	    ($type =~ m#text/# and $type ne 'text/html') or
	    $type eq 'application/pgp') {
		return $entity->bodyhandle;
	} elsif ($type eq 'multipart/alternative') {
		# RFC 2046 says we should use the last part we recognize.
		for my $part (reverse $entity->parts) {
			my $ret = getmailbody($part);
			return $ret if $ret;
		}
	} else {
		# For other multipart types, we just pretend they're
		# multipart/mixed and run through in order.
		for my $part ($entity->parts) {
			my $ret = getmailbody($part);
			return $ret if $ret;
		}
	}
	return undef;
}

sub get_addresses {
	return
	    map { $_->address() }
	    map { Mail::Address->parse($_) } @_;
}

sub escapelog {
	my @log = @_;
	map { s/^([\01-\07\030])/\030$1/gm } @log;
	return \@log;
}

sub isstrongseverity {
    my $severity = shift;
    $severity = $gDefaultSeverity if $severity eq '';
    return grep { $_ eq $severity } @gStrongSeverities;
}


@severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
@showseverities= @severities;
grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
%displayshowseverities= %gSeverityDisplay;

# compatibility
if (defined $gFowardList and not defined $gForwardList) {
    $gForwardList = $gFowardList;
}

1;