# -*- Mode: Perl -*- 
#
# Catalog.pm 
# Copyright (C) 1997-1998 Federico Di Gregorio.
#
# This module is part of the Definitive Type Manager package.   
#
# 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, 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 MERCHANTIBILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.

=head1 NAME

DTM::Catalog - Object-Oriented management of DTM font catalogs.

=cut

package DTM::Catalog;

require 5.004;
use DTM::Snippet;
use DTM::Utils;
use strict;
use vars qw();


=head1 DESCRIPTION

The B<Catalog> package provides an easy perl interface to the
various font catalogues used by the Definitive Type Manager system.
Other libraries offer the same type of facilities for other
languages (e.g., C or C++). 

At now the catalog does very few checks on the information passed
to it. It simply use that information to modify the catalog (when
fonts are installed or removed), or to search the catalog for
specific fonts.

For more information about catalogs, fonts and the DTM system,
please read the I<Definitive Font Manager Guide>.
=cut


=head1 HOOKS

Sometimes an application needs to know when fonts are installed
or removed from the system. The Catalog class provides some hooks
that can be used by an application that wants to be notified when
the catalog is taking a particular action. 
The available hooks are:

    InstallingFont (args: catalog, snippet) -- 
        a font is being installed 
    RemovingFont (args: catalog, snippet) -- 
        a font is being removed
    AddingPath (args: catalog, snippet, path) -- 
        a font installed some components in a new (i.e., never 
        used before) directory
    DeletingPath (args: catalog, snippet, path) -- 
        the last font using this directory has been removed 
        from the system
    Forwarding (args: catalog, fwd_command) -- 
        this one is not generated by the catalog itself.
        If requested the catalog will forward this to all the hooked
        applications. (This will be used by the B<dtm> program.)

A new hook is added with the method I<add_hook>:

    $catalog->add_hook($hook_name, $hook_function, $priority);

where $hook_name is one of the names described above and $hook_function
a reference to the function to be invoked (i.e.,
$hook_function = \&hook_sub).

A bunch of hooks is added by calling I<add_hooks>:

    $catalog->add_hooks($priority, %hooks)
    DTM::Catalog->add_hooks($priority, %hooks)

where %hooks is a mapping of name => functions.
(The second version is used by the autoloaded hooks.)

B<Note.> At now there is no need to remove the hooks, so that 
functionality is unimplemented. 

B<Note.> The hooks are, obviously, B<not> saved with the catalog.

=cut

# these are the valid hook types
my @hook_types = ('InstallingFont',
		  'RemovingFont',
		  'AddingPath',
		  'DeletingPath',
		  'Forwarding');

# this is the last catalog created, usefull when adding autohooks
my $last_catalog;

sub add_hook {
    my $self = shift;
    my $key = shift;
    my $func = shift;
    my $pri = shift;

    my @new_hooks;

    if ($pri) {
	@new_hooks = ($func, @{$self->{HOOKS}->{$key}});
    }
    else {
	@new_hooks = (@{$self->{HOOKS}->{$key}}, $func);
    }

    if (! grep {/$key/} @hook_types) {
	return __set_error("invalid hook type: $key");
    }
    else {
	$self->{HOOKS}->{$key} = \@new_hooks;
	return 1;
    }
}

sub add_hooks {
    my $self = shift;

    # if $self is not a reference it is the priority
    do {unshift @_, $self; $self = $last_catalog;}  unless ref($self);

    my $pri = shift;
    my %hooks = (@_);
    my $bad_hooks = "";

    

    print STDERR "\nDEBUG: catalog $self->{CATALOG}: installing hooks:\n"
	if $self->{DEBUG};
    while (my ($name, $func) = each %hooks) {
	if (!(grep {/$name/} @hook_types)) {
	    $bad_hooks .= "$name ";
	    print STDERR "DEBUG: bad hook: $name\n"
		if $self->{DEBUG};
	}
	else {
	    my @new_hooks;
	    if ($pri) {
		@new_hooks = ($func, @{$self->{HOOKS}->{$name}});
	    }
	    else {
		@new_hooks = (@{$self->{HOOKS}->{$name}}, $func);
	    }
	    $self->{HOOKS}->{$name} = \@new_hooks;
	    print STDERR "DEBUG:    @new_hooks\n"
		if $self->{DEBUG};
	}
    }	
    print STDERR "DEBUG: catalog $self->{CATALOG}: END DEBUG\n"
	if $self->{DEBUG};

    if ($bad_hooks eq "") {
	return 1;
    }
    else {
	__set_error("invalid hook types: $bad_hooks");
	return 0;
    }
}

# __call_hook is used by the catalog to invoke the hooked functions 

sub __call_hook {
    my $self = shift;
    my $key = shift;

    foreach my $func (@{$self->{HOOKS}->{$key}}) {
	next unless $func;
	&$func(@_);
    }
};


=head1 METHODS

=head2 new, sys_catalog, user_catalog

I<new> is the default constructor for the font catalog. It takes four 
arguments: the file from where the catalog should be initialized,
a flag inidicating what to do if the catalog file doesn't
exist, the type of fonts in the catalog and the path to the
auto-hooks.

    $catalog = DTM::Catalog->new($file, $create, $type, $path);

The creation of a brand new catalog fails if $create is different
from the 'CREATE' keyword. $type is used only for the selection of
the auto-hooks and the hooks themselves should be written in perl
and are loaded from the files $path/*.$type. They should prefix
the sub names by their basename, i.e., the `*' above.

I<sys_catalog> and I<user_catalog> both return a catalog of the
given type. The former returns one of the system wide catalogs
that usually reside in /etc/dtm/catalogs while the latter returns
the private catalog of the current user (this is usually located in
$HOME/fonts/catalogs).

    $catalog = DTM::Catalog::sys_catalog($type)
    $catalog = DTM::Catalog::user_catalog($type)

=cut

# these are the standard catalog locations
my $sys_catalog_path = '/etc/dtm/catalogs';
my $user_catalog_path = "$ENV{HOME}/fonts/catalogs";
my $sys_methods_path = '/etc/dtm/methods';
my $user_methods_path = "$ENV{HOME}/fonts/methods";

# Here are two methods used to read and write the catalog
# of fonts from/to disk. I am not sure about providing 
# public methods to do so, because is dangerous to read a
# new catalog in an initialized one. Note that $catalog
# should be a reference to the real %catalog.

sub __load_catalog {
    my $self = shift;
    my ($snip, $lines, $id);
 
    if (open(CATALOG, $self->{CATALOG})) {
	while (<CATALOG>) {
	    chop;
	    next if /^#/;

	    # accumulates lines
	    $lines .= $_ . "\n";

	    do {$self->{PATHS}->{$1} = $2; next;} 
	    if /PathRefs:\s*(.+)\s+(\d+)/;

	    # a new snippet, clears lines buffer
	    do {$lines = $_."\n"; $id = "$1";} 
	    if /^Font\s(.+)/;

	    # the end of the snippet, builds one from the
	    # accumulated lines
	    do {
		$self->{FONTS}->{$id} = new DTM::Snippet;
		$self->{FONTS}->{$id}->build_from_string($lines);}
	    if /^EndFont/;	    
	}
	close(CATALOG);
	return 1;
    }
    else {
	return 0;
    }
};

sub __save_catalog {
    my $self = shift;

    if (open(CATALOG, ">$self->{CATALOG}")) {

	# writes the header
	print CATALOG "Catalog\n";

	# writes fontpaths
	print CATALOG "\n";
	while (my ($path, $num) = each %{$self->{PATHS}}) {
	    print CATALOG "PathRefs: $path $num\n" if $path;
	}

	# writes snippets
	print CATALOG "\n";
	print STDERR "\nDEBUG: catalog $self->{CATALOG}: writing snippets:\n"
	    if $self->{DEBUG};
	foreach my $snippet (values %{$self->{FONTS}}) {
	    print CATALOG $snippet->dump_to_string() . "\n";
	    print STDERR "DEBUG:    " . $snippet->get_attr('ID') . "\n"
		if $self->{DEBUG};
	}
	print STDERR "DEBUG: catalog $self->{CATALOG}: END DEBUG\n"
	    if $self->{DEBUG};
	
	print CATALOG "EndCatalog\n";
	close(CATALOG);
    }
    else {
	return $self->__set_error("can't write catalog `$self->{CATALOG}'");
    }
}

sub new {
    my $this = shift;
    my $class = ref($this) || $this;
    my $self = {};

    # initialize new catalog (the array should be there
    # because I can't dereference a void pointer to an array)
    $self->{CATALOG} = shift ||
	return __set_error("the catalog file parameter is missing");
    my $create = shift || 'CREATE';
    $self->{HOOKS} = {InstallingFont => [],
		      RemovingFont => [],
		      AddingPath => [],
		      DeletingPath => [],
		      Updating => []};
    $self->{TYPE} = shift || 'unknown';
    $self->{AUTOPATH} = shift || '';
    $self->{VERSION} = 1;
# $self->{DEBUG} = 1;

    # load from file if exists 
    __load_catalog($self) or do {
	return __set_error("catalog `$self->{CATALOG}' doesn't exists") 
	    unless $create eq 'CREATE';
    };

#### DEBUG ####
    if ($self->{DEBUG}) {
	print STDERR "\nDEBUG: catalog $self->{CATALOG}: snippets loaded:\n";
	foreach my $i (keys %{$self->{FONTS}}) {
	    print STDERR "DEBUG:    $i\n";
	}
	print STDERR "DEBUG: catalog $self->{CATALOG}: path refs:\n";
	foreach my $i (keys %{$self->{PATHS}}) {
	    print STDERR "DEBUG:    $i = $self->{PATHS}{$i}\n";
	}
	print STDERR "DEBUG: catalog $self->{CATALOG}: END DEBUG\n";
    }
###############

    # then i need to load the auto-hooks
    print STDERR "\nDEBUG: catalog $self->{CATALOG}: " .
	"autopath: $self->{AUTOPATH}\n"
	    if $self->{DEBUG};
    if ($self->{AUTOPATH}) {
	my @hook_files = glob("$self->{AUTOPATH}/*.$self->{TYPE}");

	# $last_catalog can be used to access the last created catalog
	$last_catalog = $self;

	foreach my $hook_file (@hook_files) {
	    print STDERR "DEBUG: catalog $self->{CATALOG}: " .
		"loading application hooks: $hook_file\n"
		    if $self->{DEBUG};
	    require $hook_file if -r $hook_file
	    }
    }

    # bless the new object
    bless $self, $class; 
}

# loads the system catalog of the given type
sub sys_catalog { 
    my $type = shift;

    return DTM::Catalog->new("$sys_catalog_path/$type.catalog", 
			     'CREATE', $type, $sys_methods_path);
}

# loads the user catalog of the given type
sub user_catalog {
    my $type = shift;
    my $methods = shift || $sys_methods_path;

    return DTM::Catalog->new("$user_catalog_path/$type.catalog", 
			     'CREATE', $type, $methods);
}

# DESTROY just saves the state of the catalog, when
# the catalog gets recycled
# FIX: __save_catalog interrupts before saving the snippets, why?
sub DESTROY {
    my $self = shift;
#    __save_catalog($self) 
#	if $self->{AUTOSAVE} == 'YES';
}


=head2 add

I<add> adds a new font to the font catalog. In the future I<add>
will check the hash given as argument to see if the font is a
valid one, but at now, it does nothing.

    $catalog->add($snippet);

where $snippet is a font snippet from the B<Snippet> package
that contains some special keys that I<add> uses as hints 
for the install.
(The special keys will be of the B<install> class.)

=cut

sub add {
    my $self = shift;
    my $snippet = shift;
    my %info = $snippet->get_attrs();
    my %args = ();

    # check if a font with the same name is installed
    return $self->__set_error("font with ID `$info{ID}' " .    
		     "already exists in catalog")
	if (exists $self->{FONTS}{$info{ID}});

    # and saves everything adding the information
    # to the catalog
    $self->{FONTS}->{$info{ID}} = $snippet;

#### DEBUG ####
    if ($self->{DEBUG}) {
	print STDERR "\nDEBUG: catalog $self->{CATALOG}: adding snippet:\n";
	print STDERR "DEBUG:    $info{ID} = $self->{FONTS}->{$info{ID}}\n";
	print STDERR "DEBUG: catalog $self->{CATALOG}: END DEBUG\n";
    }
###############

    # then calls the hooks, first checks to see if a new path has
    # been added...
    foreach my $i (keys %info) {
	if ($i =~ /(.+)Path/) {
	    if (! exists $self->{PATHS}->{$info{$i}}) {
		$self->{PATHS}->{$info{$i}} = 1;
		$self->__call_hook('AddingPath', $self, $snippet, $info{$i});
	    }
	    else {
		$self->{PATHS}->{$info{$i}} += 1;
	    }
	}
    }
				 
    # the the AddingFont hook is called
    $self->__call_hook('InstallingFont', $self, $snippet);

    return $snippet;
}


=head2 alias

I<alias> works pretty much like I<add>, but no files are
moved, because this method is used to create aliases to
existing fonts (hint: you didn't buy Helvetica, but you
have a font that looks much like...)

If the aliased font doesn't exists (i.e., it isn't in the
catalog), an error is returned. 

    $catalog->alias($snippet);

The snippet pointed by $snippet should cantain an B<Alias> key,
with the ID of the aliases font.

=cut

sub alias {
    my $self = shift;
    my $snippet = shift;
    my %info = $snippet->get_attrs();    

    # checks the aliased font
    my $alias = $self->find($info{Alias});
    return $self->__set_error("font with ID `$info{ID}' is an alias to " .
			      "`$info{Alias}' but the aliased font " .
			      "doesn't exists")
	unless $alias;

    my %alias_info = $alias->get_attrs();

    # an alias of an alias? lets get the original one!
    while ($alias && exists $alias_info{Alias}) { 
	$alias = $self->find($alias_info{Alias});
	%alias_info = $alias->get_attrs();
    } 

    # puts a pointer to the real font
    $snippet->set_attr('Alias', $alias_info{ID});

    return $self->add($snippet);
}


=head2 merge

I<merge> is the third method used to add fonts, and the preferred
one of the Debian developers. It just scans the given catalog
and adds all the fonts to the current one. 
All the encountered errors are logged and
can be retrieved by a call to the I<error> method. 
(This is highly suggested!)

    $catalog->merge($another_catalog);

=cut

sub merge {
    my $self = shift;
    my $cattle = shift;
    my @keys = keys %{$cattle->{FONTS}};
    my $log;

    foreach my $key (@keys) {
	if ($cattle->{FONTS}{$key}->get_attr('Alias')) {
	    $self->alias($cattle->{FONTS}{$key}) or
		$log .= "  " . $self->error() . "\n";
	}
	else {
	    $self->add($cattle->{FONTS}{$key}) or 
		$log .= "  " . $self->error() . "\n";
	}
    }
    $self->__set_error($log) if $log;
}


=head2 filter

I<filter> returns a selection of snippets from the catalog:

    @snippets = $catalog->filter($attr, @patterns);

@patterns, if present, should an array of regular expressions 
used to filter the specified attribute.

=cut

sub filter {
    my $self = shift;
    my $attr = shift || 'ID';
    my @patterns = (@_);
    my @snippets = values %{$self->{FONTS}};
    my @grabbed = ();

    if (@patterns) {
	print "DEBUG: catalog $self->{CATALOG}: doing patterns\n" 
	    if $self->{DEBUG};
      SNIPPET:
	foreach my $snippet (@snippets) {
	    foreach my $pattern (@patterns) {
		my $test = $snippet->get_attr($attr);
		if ($test =~ /$pattern/) {
		    @grabbed = (@grabbed, $snippet);
		    next SNIPPET;
		}
	    }
	}
    } 
    else {
	@grabbed = (@snippets);
    }
    
    return @grabbed;
}
    

=head2 find

I<find> returns the snippet with the given ID, or undef in the
snippet is not installed in the system.

    $snippet = $catalog->find($font_id);

It is much like calling filter('ID', $font_id), but faster.

=cut

sub find {
    my $self = shift;
    my $id = shift;
 
    return $self->{FONTS}{$id};
}


=head2 remove

I<remove> removes a font from the catalog:

    $catalog->remove($snippet);

where $snippet is the same catalog snippet used to install the font
or the one returned by the I<find> method.
The call to I<remove> fails only if the font has one or more aliases
pointing to it. If the font doesn't exists the call succedes (but no
hooks are called).

=cut

sub remove {
    my $self = shift;
    my $snippet = shift;
    my %info = $snippet->get_attrs();
    
    # check if a font with the given name is installed
    do {
	$self->__set_error("font with ID $info{ID} doesn't exist in catalog");
	print STDERR "\nDEBUG: catalog $self->{CATALOG}: " .
	    "font with ID $info{ID} doesn't exists in catalog\n"
		if $self->{DEBUG};
	return 1;
    } unless exists $self->{FONTS}{$info{ID}};

    # then check for aliases 
    print STDERR "\nDEBUG: catalog $self->{CATALOG}: comparing aliases:\n"
	if $self->{DEBUG};
    while (my ($id, $font) = each %{$self->{FONTS}}) {
	my $alias = $font->get_attr('Alias');
	print STDERR "DEBUG:    $info{ID} <-> $alias\n"
	    if $self->{DEBUG};
	if ($alias and ($alias eq $info{ID})) { 
	    # devo resettare l'iteratore
	    my @gonzo = keys %{$self->{FONTS}};
	    return $self->__set_error("font with ID $info{ID} has " .
				      "one or more aliases; skipping");
	}
    }

    # then calls the hooks (giving them the *real* snippet in the
    # catalog, not the one we got. 
    # first the RemovingFont hook is called
    $self->__call_hook('RemovingFont', $self, $self->{FONTS}->{$info{ID}});

    # then checks to see if this was the last font in the given path
    foreach my $i (keys %info) {
	if ($i =~ /(.+)Path/) {
	    $self->{PATHS}->{$info{$i}} -= 1;
	    if ($self->{PATHS}->{$info{$i}} == 0) {
		$self->__call_hook('DeletingPath', $self, 
				   $self->{FONTS}->{$info{ID}}, 
				   $info{$i});
	    }
	    # if the pathrefs is negative or zero remove it
	    delete $self->{PATHS}->{$info{$i}}
	        if $self->{PATHS}->{$info{$i}} <= 0;
	}
    }
    
    # and finally deletes the font from the catalog
    delete $self->{FONTS}->{$info{ID}};
    return ($snippet); 
}


=head2 save

I<save> save just saves the catalog to the disk.

    $catalog->save();

=cut

sub save {
    my $self = shift;
    __save_catalog($self);
}


=head2 error

I<error> returns a string that contains the reason of the
last error or an empty string. A call to I<error> clears
the error string and following calls just return the empty
string.

    Debian::DTM::Catalog->error();
    $catalog->error();

=cut

# This is a private function used to set the error.
# Note that error codes are local to the catalog that
# generated them.

my $ERROR = "";

sub __set_error {
    my $self = shift;

    # this is an object
    if (ref($self)) { 
	$self->{ERROR} = shift;
    }
    # this is the class
    else {
	$ERROR = $self;
    }
    return 0;
}

sub error {
    my $self = shift;
    my $err;

    # this is an object
    if (ref($self)) { 
	$err = $self->{ERROR};
	$self->{ERROR} = "";
    }
    # this is the class
    else {
	$err = $ERROR;
	$ERROR = "";
    } 
    return $err;
}


# these are used to debug dtm...

sub dump_font {
    my $self = shift;
    my $font = shift;
    
    while (my ($key, $value) = each %$font) {
	print "  $key = $value\n";
    }
}

sub dump_catalog {
    my $self = shift;
 
    foreach my $info (keys %{$self->{FONTS}}) {
	print "\nFont $info:\n";
	$self->dump_font($self->{FONTS}{$info});
    }
}


=head1 BUGS

None so far.

=cut

=head1 AUTHOR

Federico Di Gregorio <fog@debian.org>

=cut


1;