#!/usr/bin/perl

=head1 NAME

install-docs - manage online Debian documentation

=cut

# ---beginning-of-configuration-part---

$DATA_DIR = "/var/lib/doc-base/info";

$dwww_update = "/usr/bin/update-menus";

# ---end-of-configuration-part---

use File::Basename;
# set umask explicitly
umask 022;

=head1 SYNOPSIS

 install-docs -i --install | 
              -r --remove  |
              -s --status  |
              -L --listfiles
              [ -v, --verbose ]
                <doc-id | file>

=head1 DESCRIPTION

B<install-docs> is a tool allow Debian package maintainers to register
documentation to various documentation systems.  It currently supports
B<dhelp> and B<dwww>.

This manual page provides a quick synopsis of B<install-docs> usage.
Full documentation can be found in the documentation, including a
description of the control file syntax and grammar.

=head1 OPTIONS

=over 4

=cut

while ($arg = shift) {

  if (($arg eq '-v') or ($arg eq '--verbose')) {

=item B<-v> | B<--verbose>

Operate verbosely.

=cut
    $verbose = 1;
    next;
  }

  if (($arg eq '-i') or ($arg eq '--install')) {

=item B<-i> I<file> | B<--install> I<file>

Install the documentation described by the control file I<file>.

=cut
    # install new docs
    ($file = shift) or die "argument missing for `install'";
    ($#ARGV == -1) or die "too many arguments for `install'";

    read_control_file($file);
    read_status_file(1);
    read_list_file();

    # update status
    $status{'Control-File'} = $file;
    $status_changed = 1;

    # remove any installed dhelp files (since the location could change)
    remove_files();
    
    # register documents to subsystems
    register_dhelp();
    register_dwww();

    write_list_file();
    write_status_file();

  } elsif (($arg eq '-r') or ($arg eq '--remove')) {

=item B<-r> I<docid> | B<--remove> I<docid>

Remove the documentation identified by the document identifier
I<docid>.  Document identifiers are tags which are set in the control
file, and usually correspond to the package name.

=cut
    # remove old docs
    ($docid = shift) or die "argument missing for `remove'";
    ($#ARGV == -1) or die "too many arguments for `remove'";

    if ( ! read_status_file(1) ) {
      warn("Document `$docid' is not installed, cannot remove.\n");
      exit 0;
    }
    read_control_file($status{'Control-File'});
    read_list_file();

    # remove newly created files and unregister from menus
    remove_files();
    update_dwww_menus() if $status{'Registered-to-dwww'};

    # remove data files
    remove_data_files();

  } elsif (($arg eq '-s') or ($arg eq '--status')) {

=item B<-s> I<docid> | B<--status> I<docid>

Display the status of the document identifier I<docid>.

=cut
    # display status
    ($docid = shift) or die "argument missing for `status'";
    ($#ARGV == -1) or die "too many arguments for `status'";

    read_status_file();
    read_list_file();
    read_control_file($status{'Control-File'});

    display_status_information();

  } elsif (($arg eq '-L') or ($arg eq '--listfiles')) {

=item B<-L> I<docid> | B<--listfiles> I<docid>

List the files associated with the document identifier I<docid>.

=back

=cut
    # display status
    ($docid = shift) or die "argument missing for `listfiles'";
    ($#ARGV == -1) or die "too many arguments for `listfiles'";

    read_status_file();
    read_list_file();

    display_listing();

  } else {
    die "invalid command line argument: $arg";
  }
}

exit 0;

# -------------------------------

# Registering to dhelp
sub register_dhelp {
  my (%update_dhelp, %removed_dhelp);
  my $dhelp_parse;

  my $format_data;
  for $format_data (@format_list) {
    next unless $$format_data{'format'} eq 'html'; # dhelp only understand html
    # get directory of index file
    my $file = basename($$format_data{'index'});
    my $dir = dirname($$format_data{'index'});
    $dir =~ m|^/| or 
      die "Index file has to be specified with absolute path: $$format_data{'index'}";

    # ensure the documentation is in an area dhelp can deal with
    if ( $dir !~ m|^/usr/(share/)?doc| ) {
	print "register_dhelp: skipping $dir/$file
   because dhelp only knows about /usr/doc and /usr/share/doc\n"
	    if $verbose;
	next;
    }
    # set the program name, depending on the dir
    if ( $dir =~ m|^/usr/doc| ) {
	$dhelp_parse = "/usr/sbin/dhelp_parse_fsstnd";
    } else {
	$dhelp_parse = "/usr/sbin/dhelp_parse";
    }

    my @dhelp_data;
    my $dhelp_file = "$dir/.dhelp";
    # dhelp file already exists?
    if (-f $dhelp_file) {
      # is this file from us?
      #if (not exists $list{$dhelp_file}) {
	# no, skip action -- actually we could probably tolerate this condition
	#warn "warning: skipping foreign dhelp file $dhelp_file";
	#next;
      #}

      # yes, read in the file
      $dhelp_data = read_dhelp_file($dhelp_file);
      
      # take a look at the contents
      my $i;
      for ( $i = 0; $i <= $#$dhelp_data; $i++ ) {
	if ($$dhelp_data[$i]{'filename'} =~ /^\s*$file\s*$/o) {
	  # remove this entry; we'll add it back below
	  print "register_dhelp: found entry for $file in $dhelp_file, replacing\n"
	    if $verbose;
	  splice(@$dhelp_data, $i, 1);
	}
      }
      
      if ( -x $dhelp_parse && ! defined($removed_dhelp{$dir}) ) {
	# before we edit .dhelp, we need to remove the entry for it
	print "Executing $dhelp_parse -d $dir for changed .dhelp file\n"
	  if $verbose;
	if ( system("$dhelp_parse -d $dir") != 0 ) {
	  # this is not a fatal condition
	  warn "warning: error occured during execution of $dhelp_parse -d";
	}
	# remember that we did this do we don't do it again
	$removed_dhelp{$dir} = 1;
      }
    } else {
      # no file yet, let's make an empty ref to fill in below
      $dhelp_data = [];
    }

    # last minute data munging,
    # FIXME when we finally get a real document hierarchy
    my $dhelp_section;
    ( $dhelp_section = $$doc_data{'section'} ) =~ tr/A-Z/a-z/;
    $dhelp_section =~ s|^apps/||;
    # now push our data onto the array (undefs are ok)
    push(@$dhelp_data, {
			'filename'    => $file,
			'directory'   => $dhelp_section,
			'linkname'    => $$doc_data{'title'},
			'description' => $$doc_data{'abstract'},
		       }
	);

    print "Updating $dhelp_file\n" if $verbose;
    add_file($dhelp_file);
    write_dhelp_file($dhelp_file, $dhelp_data);

    $update_dhelp{$dir} = 1;

    # set status
    $status{'Registered-to-dhelp'} = 1;
    $status_changed = 1;

  }

  if (-x $dhelp_parse) {
    for $dir (keys %update_dhelp) {
      print "Executing $dhelp_parse -a $dir\n" if $verbose;
      if (system("$dhelp_parse -a $dir") != 0) {
	warn "warning: error occured during execution of $dhelp_parse -a";
      }
    }
  }

}

# Registering to dwww:
sub register_dwww {
  for $format_data (@format_list) {
    next unless $$format_data{'format'} eq 'html';

    my $dwww_file = "/usr/lib/menu/doc-base-$docid";
    # dwww file already exists?
    if (-f $dwww_file) {
      # is this file from us?
      if (not exists $list{$dwww_file}) {
	# no, skip action
	warn "warning: skipping foreign dwww file $dwww_file";
	next;
      }
    }

    print "Writing $dwww_file\n" if $verbose;
    add_file($dwww_file);
    open(OUT,">$dwww_file")
      or die "$dwww_file: cannot open file for writing: $!";
    my $t_s = $$doc_data{'section'};
    $t_s =~ s/\n/ /g;
    $t_s =~ s/"/\\"/g;
    my $t_t = $$doc_data{'title'};
    $t_t =~ s/\n/ /g;
    $t_t =~ s/"/\\"/g;
    my $t_a = $$doc_data{'abstract'};
    $t_a =~ s/\n/ /g;
    $t_a =~ s/"/\\"/g;
    my $t_i = $$format_data{'index'};
    $t_i =~ s/\n/ /g;
    $t_i =~ s/"/\\"/g;

    print OUT "?package(doc-base):needs=\"dwww\" section=\"$t_s\"\\\n";
    print OUT "     title=\"$t_t\"\\\n";
    print OUT "     description=\"$t_a\"\\\n";
    print OUT "     command=\"$t_i\"\n";
    close(OUT) or die "$dwww_file: unable to close file: $!";

    $update_dwww = 1;

    # set status
    $status{'Registered-to-dwww'} = 1;
    $status_changed = 1;
  }

  if ($update_dwww) {
    update_dwww_menus();
    undef %update_dwww;
  }
}

sub update_dwww_menus {
  if (-x $dwww_update) {
    print "Executing $dwww_update\n" if $verbose;
    if (system($dwww_update) != 0) {
      warn "warning: error occured during execution of $dwww_update";
    }
  }
}

sub remove_files {
  for $file (keys %list) {
    next unless -f $file;

    # dhelp file?
    if ($file =~ /\.dhelp$/o) {	# yes

      my $dir = dirname($file);

      # set the program name, depending on the dir
      if ( $dir =~ m|^/usr/doc| ) {
	$dhelp_parse = "/usr/sbin/dhelp_parse_fsstnd";
      } else {
	$dhelp_parse = "/usr/sbin/dhelp_parse";
      }

      if (-x $dhelp_parse) {
	# call dhelp to notice removal of document
	print "Executing $dhelp_parse -d $dir\n" if $verbose;
	if (system("$dhelp_parse -d $dir") != 0) {
	  warn "warning: error occured during execution of $dhelp_parse";
	}
      }

      print "Removing dhelp file $file\n" if $verbose;
      unlink($file) or die "$file: cannot remove file: $!";

      next;
    }

    # not a dhelp file

    print "Removing file $file\n" if $verbose;
    unlink($file) or die "$file: cannot remove file: $!";
  }
  %list = ();
  $list_changed = 1;
}

sub remove_data_files {
  my $status_file = "$DATA_DIR/$docid.status";
  if (-f $status_file) {
    print "Removing status file $status_file\n" if $verbose;
    unlink($status_file)
      or die "$status_file: cannot remove status file: $!";
  }

  my $list_file = "$DATA_DIR/$docid.list";
  if (-f $list_file) {
    print "Removing list file $list_file\n" if $verbose;
    unlink($list_file)
      or die "$list_file: cannot remove status file: $!";
  }
}

# -------------------------------

sub read_status_file {
  my ($ignore) = @_;

  my $status_file = "$DATA_DIR/$docid.status";
  if (not -f $status_file) {
    return(0) if $ignore;

    warn "Document `$docid' is not installed.\n";
    exit 1;
  }

  open(S,"$status_file")
    or die "$status_file: cannot open status file for reading: $!";
  while (<S>) {
    chomp;
    next if /^\s*$/o;
    /^\s*(\S+):\s*(.*\S)\s*$/
      or die "syntax error in status file: $_";
    $status{$1} = $2;
  }
  close(S)
    or die "$status_file: cannot close status file: $!";
}

sub write_status_file {
  return unless $status_changed;

  my $status_file = "$DATA_DIR/$docid.status";

  open(S,">$status_file")
    or die "$status_file: cannot open status file for writing: $!";
  for $k (keys %status) {
    print S "$k: $status{$k}\n";
  }
  close(S) or die "$status_file: cannot close status file: $!";

  $status_changed = 0;
}

sub display_status_information {
  print "---document-information---\n";
  print "Document: $$doc_data{'document'}\n";
  for $k (sort keys %$doc_data) {
    next if $k eq 'document';
    $kk = $k; 
    substr($kk,0,1) =~ tr/a-z/A-Z/;
    print "$kk: $$doc_data{$k}\n";
  }
  for $format_data (@format_list) {
    print "\n";
    print "---format-description---\n";
    print "Format: $$format_data{'format'}\n";
    for $k (sort keys %$format_data) {
      next if $k eq 'format';
      $kk = $k; 
      substr($kk,0,1) =~ tr/a-z/A-Z/;
      print "$kk: $$format_data{$k}\n";
    }
  }
  print "\n";
  print "---status-information---\n";
  for $k (sort keys %status) {
    print "$k: $status{$k}\n";
  }
}

sub display_listing {
  for $k (sort keys %list) {
    print "$k\n";
  }
}

sub read_list_file {
  my $list_file = "$DATA_DIR/$docid.list";
  return unless -f $list_file;

  open(L,"$list_file") 
    or die "$list_file: cannot open list file for reading: $!";
  while (<L>) {
    chomp;
    next if /^\s*$/o;
    $list{$_} = 1;
  }
  close(L) or die "$list_file: cannot close file: $!";
}

sub write_list_file {
  return unless $list_changed;

  my $list_file = "$DATA_DIR/$docid.list";

  open(L,">$list_file")
    or die "$list_file: cannot open list file for writing: $!";
  for $k (keys %list) {
    print L "$k\n";
  }
  close(L) or die "$list_file: cannot close file: $!";

  $list_changed = 0;
}

sub add_file {
  my ($file) = @_;

  return if $list{$file};

  my $data_file = "$DATA_DIR/$docid.list";
  open(L,">>$data_file")
    or die "$data_file: cannot open for appending";
  print L $file,"\n";
  close(L) or die "$data_file: cannot close file";

  $list{$file} = 1;
}

# -------------------------------

# read a dhelp file, probably more flexibly than dhelp itself
# input:
#  file name
# output:
#  returns ref to array of hashes containing our data
sub read_dhelp_file {
  my ($dhelpfile) = @_;
  my ($dhdata);			# array ref, to be returned holding all the dhelp data 
  my (@rets);			# temporary array
  
  open(FH, "<$dhelpfile") or die "open file '$dhelpfile': $!\n";
  $_ = join('', <FH>);		# slurp in the file

  while ( m{
      <item>\s*			# item defines a block, required
	  (?:			# alternate everything group
       (?:<directory>		# directory is starting, required
	 ([^<]+)		#   $1
       )			# ... ending
	   |
       (?:<dirtitle>		# dirtitle is starting, optional
         ([^<]+)		#   $2 until next tag start
       )			# ... ending
	   |
       (?:<linkname>		# linkname is starting, optional
         ([^<]+)		#   $3
       )			# ... ending
	   |
       (?:<filename>		# filename is starting, optional
         ([^<]+)		#   $4
       )			# ... ending
	   |
       (?:<description>		# filename is starting, optional
         (.*?)			#  $5, non greedy
       </description>)		# ... ending
	   )*			# end alternating
       \s*</item>		# spaces ok, item ends
      }gscx )
    {
      @rets =  ($1, $2, $3, $4, $5);
      @rets = map { chomp; $_; }  @rets;
      # push a hashref of our dhelp data item onto the $dhdata array
      push(@$dhdata, {
		      'directory'   => $rets[0],
		      'dirtitle'    => $rets[1],
		      'linkname'    => $rets[2],
		      'filename'    => $rets[3],
		      'description' => $rets[4],
		     });
    }
  
  close FH;
  return $dhdata;
}


sub write_dhelp_file {
  my ($file, $data) = @_;
  
  open(FH, ">$file") or die "cannot open dhelp file '$file':";
  foreach $rec (@$data) {
    print FH "<item>\n";
    foreach $field ((
			'directory', 'dtitle', 'linkname', 'filename'
		       )) {
      print FH "<$field>$$rec{$field}\n" if length($$rec{$field});
    }
    print FH "<description>\n$$rec{description}\n</description>\n"
      if length($$rec{'description'});
    print FH "</item>\n\n";
  }
  close FH;
}

# -------------------------------

sub read_control_file_section {
  my ($pfields) = @_;

  my $empty = 1;
  my ($cf,$v);
  while (<IN>) {
    chomp;

    # empty line?
    if (/^\s*$/o) {
      if ($empty) {
	next;
      } else {
	last;
      }
    }

    $empty = 0;

    # new field?
    if (/^(\S+)\s*:\s*(.*)$/) {
      ($cf,$v) = (lc $1,$2);
      #print STDERR "$cf -> $v\n";
      if (exists $$pfields{$cf}) {
	warn "warning: $cf: overwriting previous setting of control field";
      }
      $$pfields{$cf} = $v;
    } elsif (/^\s+(\S.*)$/) {
      $v = $1;
      defined($cf) or die "syntax error in control file: no field specified";
      #print STDERR "$cf -> $v (continued)\n";
      $$pfields{$cf} .= "\n$v";
    } else {
      die "syntax error in control file: $_";
    }
  }

  return not $empty;
}

# reads control file specified as argument
# output:
#    sets $docid
#    sets $doc_data to point to a hash containing the document data
#    sets @format_list, a list of pointers to hashes containing the format data
sub read_control_file {
  my ($file) = @_;

  open(IN, $file) or 
      open(IN, "/usr/share/doc-base/$file") or
	  die "$file: cannot open control file for reading: $!\n";

  $doc_data = {};
  read_control_file_section($doc_data) or die "error: empty control file";
  # check for required information
  ($docid = $$doc_data{'document'}) 
    or die "error in control file: `Document' value not specified";
  $$doc_data{'title'}
    or die "error in control file: `Title' value not specified";

  undef @format_list;
  $format_data = {};
  while (read_control_file_section($format_data)) {
    # adjust control fields
    $$format_data{'format'} =~ tr/A-Z/a-z/;
    # check for required information
    $$format_data{'format'}
      or die "error in control file: `Format' value not specified";
    $$format_data{'files'}
      or die "error in control file: `Files' value not specified";
    if ($$format_data{'format'} eq 'html') {
      $$format_data{'index'}
        or die "error in control file: `Index' value missing for type HTML";
    } elsif ($$format_data{'format'} eq 'debiandoc-sgml') {
      # no additional fields required
    } elsif ($$format_data{'format'} eq 'text') {
      # no additional fields required
    } elsif ($verbose) {
      warn "warning: ignoring unknown format `$$format_data{'format'}'";
    }
    
    push(@format_list,$format_data);
    $format_data = {};
  }
  close(IN);
}


=head1 BUGS

None known, but a much more robust system is being planned as the next
generation of doc-base.

=head1 SEE ALSO

dwww(8), Debian doc-base Manual
F</usr/doc/doc-base/doc-base.html/index.html>, dhelp Manual
F</usr/doc/dhelp/dhelp.html>

=head1 AUTHOR

This program was originally written by Christian Schwarz
<schwarz@debian.org>, for the Debian GNU/Linux system.  Adam Di Carlo
<aph@debian.org> is currently maintaining and extending it.

This software was meant to be for the benefit of the entire Debian
user and developer community.  If you are interested in being involved
with this software, please join the mailing list
<debian-doc@lists.debian.org>.

=cut