JezK
Edit File: install-sgmlcatalog
#!/usr/bin/perl ## ---------------------------------------------------------------------- ## install-sgmlcatalog : Debian SGML catalog management tool ## ---------------------------------------------------------------------- ## Copyright (c) 1997 Christian Schwarz ## Copyright (c) 2001-2004 Ardo van Rangelrooij ## ## This is free software; see the GNU General Public Licence version 2 ## or later for copying conditions. There is NO warranty. ## ---------------------------------------------------------------------- ## ---------------------------------------------------------------------- use strict; use warnings; ## ---------------------------------------------------------------------- use Getopt::Long qw( &GetOptions ); ## ---------------------------------------------------------------------- $0 =~ m|[^/]+$|; ## ---------------------------------------------------------------------- my $name = $&; ## ---------------------------------------------------------------------- use vars qw( $package ); use vars qw( $quiet ); ## ---------------------------------------------------------------------- Getopt::Long::Configure( 'no_ignore_case' ); if ( ! GetOptions( 'quiet' => \$quiet, 'remove=s' => \$package, ) ) { &usage(); exit 1; } ## ---------------------------------------------------------------------- if ( ! defined( $package ) ) { &usage(); exit -1; } ## ---------------------------------------------------------------------- &remove( $package ); ## ---------------------------------------------------------------------- exit 0; ## ---------------------------------------------------------------------- sub remove { ## ------------------------------------------------------------------ my $package = $_[0]; ## ---------------------------------------------------------------------- my $catalog = '/etc/sgml/transitional.cat'; my $backup = '/etc/sgml/transitional.cat.old'; ## ------------------------------------------------------------------ return if ( ! -f $catalog ); ## ---------------------------------------------------------------------- my $top_marker = '-- START SGML CATALOG ENTRY FOR PACKAGE'; my $bottom_marker = '-- END SGML CATALOG ENTRY FOR PACKAGE'; my $eol_marker = '--'; ## ------------------------------------------------------------------ my @data; ## ------------------------------------------------------------------- open( CATALOG, '<', $catalog ) or &error( "cannot open SGML catalog $catalog for reading: $!" ); ## ------------------------------------------------------------------- while ( <CATALOG> ) { chop; if ( /$top_marker $package $eol_marker/o ) { if ( $data[ $#data ] =~ /^\s*/o ) { pop( @data ); } while ( !/$bottom_marker $package $eol_marker/o ) { if ( not ($_ = <CATALOG>) ) { &error( "cannot find bottom marker for package $package:\n $bottom_marker $package $eol_marker\nplease remove the entry for $package manually" ); } } } else { push( @data, $_ ); } } ## ------------------------------------------------------------------ close( CATALOG ) or &error( "cannot close SGML catalog $catalog: $!" ); ## ------------------------------------------------------------------ if ( -f $catalog ) { if ( -f $backup ) { unlink( $backup ) or &error( "cannot remove backup of catalog $backup: $!" ); } rename( $catalog, $backup ) or &error( "cannot rename $catalog to $backup: $!" ); } ## ------------------------------------------------------------------ open( CATALOG, '>', $catalog ) or &error( "cannot open SGML catalog $catalog for writing: $!" ); ## ------------------------------------------------------------------ for ( @data ) { print CATALOG "$_\n"; } ## ------------------------------------------------------------------ close( CATALOG ) or &error( "cannot close SGML catalog $catalog: $!" ); } ## remove ## ---------------------------------------------------------------------- sub usage { ## ------------------------------------------------------------------ print STDERR <<END; Usage: $name --remove package END } ## usage ## ---------------------------------------------------------------------- sub error { ## ------------------------------------------------------------------ die "$name: error: $_[0]\n"; } ## error ## ----------------------------------------------------------------------