# ==================================================================
# Gossamer Links - enhanced directory management system
#
#   Website  : http://gossamer-threads.com/
#   Support  : http://gossamer-threads.com/scripts/support/
#   CVS Info : 087,071,086,086,085      
#   Revision : $Id: Category.pm,v 1.29 2009/05/11 05:57:45 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================

package Links::Table::Category;
# ==================================================================
use strict;
use Links qw/:payment :objects/;
use GT::SQL;
use GT::SQL::Table;
use GT::Lock qw/lock unlock LOCK_TRY/;
use vars qw /@ISA $ERRORS $ERROR_MESSAGE/;

@ISA = qw/GT::SQL::Table/;
$ERROR_MESSAGE = 'GT::SQL';
$ERRORS = {
    BADCATNAME => "Invalid category name: %s",
    BADCATID   => "Invalid category id: %s",
    BADCATSUG  => "There is no category with that name. Perhaps you meant: %s",
    CATEXISTS  => "A category with the name '%s' already exists.",
};

# We wrap new() to handle updating Number_of_Links - but only once: the first
# time a Category table object is created.
sub new {
    my $self = shift->SUPER::new(@_) or return;

    return $self if $STASH{expired_links}++;

    my $links = $DB->table('Links');
    my $cond;
    if ($CFG->{payment}->{enabled}) {
        $cond = GT::SQL::Condition->new(
            ExpiryCounted => '=' => 0,
            ExpiryDate    => '<' => time,
            isValidated   => '=' => 'Yes'
        );
    }
    else {
        $cond = GT::SQL::Condition->new(
            ExpiryCounted => '=' => 1,
            isValidated   => '=' => 'Yes'
        );
    }
    # Don't select the ID's here because we haven't established a lock.  Since
    # most requests won't catch expired links, doing a count here to avoid
    # needing the lock is going to be slightly slower occassionally, but
    # usually faster.
    return $self unless $links->count($cond);

    # We've now determined that there _are_ links that have expired that
    # haven't been counted yet, so we establish a lock (to prevent a race
    # condition), and then update the links counts for categories that have
    # newly-expired links.  If getting the lock fails, simply return - this is
    # only likely to happen when another process has the lock and is performing
    # the updates already, or when a previous process with a lock died - the
    # 120 should make sure that such a condition doesn't last longer than 2
    # minutes.
    lock cat_link_count => 1, LOCK_TRY, 120
        or return $self;

    my @links = $links->select(ID => $cond)->fetchall_list;
    unless (@links) { # Despite the above count, there might not be links now if we had to wait for a lock
        unlock 'cat_link_count';
        return $self;
    }

    if ($CFG->{payment}->{expired_is_free}) {
        # This gets a bit hairy - expired links need to become free but NOT in
        # required categories.  On the other hand, links in non-required
        # categories don't affect the count.
        my %req_links = map { $_ => 1 } $DB->table('Category', 'CatLinks')->select(LinkID => { LinkID => \@links, Payment_Mode => $CFG->{payment}->{mode} == REQUIRED ? [GLOBAL, REQUIRED] : REQUIRED })->fetchall_list;
        my @to_free = grep !$req_links{$_}, @links;
        if (@to_free) {
            $DB->table('Links')->update({ LinkExpired => \'ExpiryDate' }, { ID => \@to_free });
            $DB->table('Links')->update({ ExpiryDate => FREE }, { ID => \@to_free });
        }
        @links = keys %req_links;
        unless (@links) {
            unlock 'cat_link_count';
            return $self;
        }
    }
    my $catlinks = $DB->table('CatLinks');
    $catlinks->select_options('GROUP BY CategoryID');
    my %cats = $catlinks->select(CategoryID => 'COUNT(*)' => { LinkID => \@links })->fetchall_list; # FIXME this query can be huge and will fail (the select() will fail and return undef)
    my %adjust;
    my %direct_adj;

    my $parents = $self->parents([keys %cats]);
    for my $cat_id (keys %cats) {
        $adjust{$cat_id} ||= 0;
        $adjust{$cat_id} += $cats{$cat_id};
        $direct_adj{$cat_id} ||= 0;
        $direct_adj{$cat_id} += $cats{$cat_id};
        for (@{$parents->{$cat_id}}) {
            $adjust{$_} ||= 0;
            $adjust{$_} += $adjust{$cat_id};
        }
    }

    my %change;
    while (my ($id, $change) = each %adjust) {
        push @{$change{$CFG->{payment}->{enabled} ? -$change : $change}}, $id;
    }
    my %change_direct;
    while (my ($id, $change) = each %direct_adj) {
        push @{$change_direct{$CFG->{payment}->{enabled} ? -$change : $change}}, $id;
    }

    while (my ($adjust, $ids) = each %change) {
        $self->update({ Number_of_Links => \("Number_of_Links " . ($adjust >= 0 ? '+' : '-') . ' ' . abs $adjust) }, { ID => $ids });
    }
    while (my ($adjust, $ids) = each %change_direct) {
        $self->update({ Direct_Links => \("Direct_Links " . ($adjust >= 0 ? '+' : '-') . ' ' . abs $adjust) }, { ID => $ids });
    }

    $links->update({ ExpiryCounted => $CFG->{payment}->{enabled} ? 1 : 0 }, { ID => \@links });

    unlock 'cat_link_count';

    return $self;
}

sub add {
# -------------------------------------------------------------------
# Adds a category, but passes it through the plugin system.
#
    my $self = shift;
    my $p    = (ref $_[0] eq 'HASH') ? shift : {@_};

    $PLG->dispatch('add_category', sub { return $self->_plg_add(@_) }, $p);
}

sub _plg_add {
# -------------------------------------------------------------------
# Add a category.
#
    my ($self, $p) = @_;

    $self->can_add($p) or return;

# If successful, we need to update timestamps of parents to denote a change.
    if (my $id = $self->SUPER::add($p)) {
        if ($p->{FatherID}) {
            $self->update(
                { Timestmp => \"NOW()" },
                { ID => $self->parents($id) },
                { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }
            );
        }
        return $id;
    }
    else {
        return;
    }
}

sub can_add {
# -------------------------------------------------------------------
# Confirms that a category can be added.
#
    my $self = shift;
    my $p = $self->common_param(@_) or return $self->warn(BADARGS => 'Usage: $table->add(HASH or HASH_REF or CGI)');

# Checks that the FatherID exists and set the full name.
    $p->{FatherID} ||= 0;
    if ($p->{FatherID} =~ /\D/) {
        my $sth = $self->select(ID => Full_Name => { Full_Name => $p->{FatherID} });
        if (my @row = $sth->fetchrow) {
            $p->{FatherID} = $row[0];
            $p->{Full_Name} = "$row[1]/$p->{Name}";
        }
        else {
            my $names = $self->suggestions($p->{FatherID});
            return $self->warn(
                @$names
                    ? (BADCATSUG  => '<ul>' . join('', map "<li>$_</li>", @$names) . '</ul>')
                    : (BADCATNAME => $p->{FatherId})
            );
        }
    }
    elsif ($p->{FatherID} != 0) {
        my $full_name = $self->get_name_from_id($p->{FatherID}) or return $self->warn(BADCATID => $p->{FatherID});
        $p->{Full_Name} = "$full_name/$p->{Name}";
    }
    else {
        $p->{Full_Name} = $p->{Name};
    }

# Checks that there is no other category with the same (Name, FatherID)
    return $self->warn(CATEXISTS => $p->{Name})
        if $self->count({ Name => $p->{Name}, FatherID => $p->{FatherID} });

    return 1;
}

sub delete {
# -------------------------------------------------------------------
# Deletes a category, but passes through the plugin system.
#
    my ($self, $where) = @_;
    if (not ref $where or ref $where eq 'ARRAY') {
        $where = { ID => $where };
    }
    return $self->fatal(BADARGS => 'Usage: $category->delete(condition)')
        unless ref $where eq 'HASH' or UNIVERSAL::isa($where, 'GT::SQL::Condition');

    my $ret;
    my %cats = $self->select(qw/ID Direct_Links/ => $where)->fetchall_list;
    if ($PLG->active_plugins('delete_category')) {
        for my $id (keys %cats) {
            my $r = $PLG->dispatch('delete_category', sub { return $self->SUPER::delete(@_) }, { ID => $id });
            $ret += $r if defined $r;
        }
        $ret = '0 but true' if (defined $ret and $ret == 0) or not keys %cats;
    }
    else {
        $ret = $self->SUPER::delete($where);
    }

    return $ret unless $ret;

# Clear out the cache as the hierarchy has changed.
    $self->_clear_cache;

    $ret;
}

sub modify {
# -------------------------------------------------------------------
# Modifies a category, but passes through the plugin system.
#
    my ($self, $cat) = @_;
    $PLG->dispatch('modify_category', sub { return $self->_plg_modify(@_) }, $cat);
}

sub _plg_modify {
# -------------------------------------------------------------------
# Modify a single category.
#
    my $self = shift;
    my $set  = shift      or return $self->error('BADARGS', 'FATAL', "Usage: \$cat->modify( { col => value ... } ).");
    my $id   = $set->{ID} or return $self->error('BADARGS', 'FATAL', "No primary key passed to modify!");

# Get the original info.
    my $orig = $self->select(qw/ID FatherID Full_Name Name Number_of_Links/ => { ID => $id })->fetchrow_hashref
        or return $self->warn(BADCATID => $id);

# Fix up the father ID.
    $set->{FatherID} ||= 0;
    if ($set->{FatherID} !~ /^\d+$/) {
        my $new_id = $self->get_id_from_name($set->{FatherID});
        if (! $new_id) {
            my $names = $self->suggestions($set->{FatherID});
            return $self->error(@$names
                ? ('BADCATSUG', 'WARN', "<ul>" . join('', map "<li>$_</li>", @$names) . "</ul>")
                : ('BADCATNAME', 'WARN', $set->{FatherID})
            );
        }
        $set->{FatherID} = $new_id;
    }

    $self->can_modify($set, $orig) or return;

    if ($orig->{Name} eq $set->{Name} and $orig->{FatherID} == $set->{FatherID}) {
        # Name and parent haven't changed, no special modify handling needed
        return $self->SUPER::modify($set);
    }
    elsif ($orig->{FatherID} == $set->{FatherID}) {
        # Name has changed, but parent is the same: update ancestors'
        # timestamps, change the full name, and update subcategory names.
        ($set->{Full_Name} = $orig->{Full_Name}) =~ s/\Q$orig->{Name}\E$/$set->{Name}/i;
        my $ret = $self->SUPER::modify($set);
        if ($ret) {
            # Update was successful, update the timestamp of old and new parents

            # Clear the as the tree just changed
            $self->_clear_cache;

            if ($set->{FatherID}) {
                my $parents = $self->parents($id);
                $self->update({ Timestmp => \"NOW()" }, { ID => $parents }, { GT_SQL_SKIP_CHECK => 1 })
                    if @$parents;
            }

            $self->update_full_name($id, $orig->{Full_Name}, $set->{Full_Name});
        }

        return $ret;
    }
    else {
        # The category has moved; get the new parent's full name and update
        my $fn = $self->select(Full_Name => { ID => $set->{FatherID} })->fetchrow;
        $set->{Full_Name} = ($fn ? "$fn/" : '') . $set->{Name};

        my $ret = $self->SUPER::modify($set);
        if ($ret) {
# Clear the cache as the tree has changed.
            $self->_clear_cache;

            $self->update_full_name($id, $orig->{Full_Name}, $set->{Full_Name});

# Now update counters on the above parents.
# Clear out the cache as otherwise we get our old parents.
            if ($orig->{Number_of_Links} != 0) {
                $self->link_count($orig->{FatherID}, -$orig->{Number_of_Links});
                $self->link_count($set->{FatherID}, $orig->{Number_of_Links});
            }
        }
# Clear out the cache.
        $self->_clear_cache;
        return $ret;
    }
}

sub update_full_name {
# -----------------------------------------------------------------------------
# Call this after changing a category's Full_Name to change all the category's
# children's full names.  Call with the category ID, old full name, and new
# full name.
#
    my ($self, $id, $old, $new) = @_;

    my @children = @{$self->children($id)};

    my $new_escaped = $self->quote($new . '/');
    my $old_offset = length($old) + 2;
    my $set;
    if (lc $self->{connect}->{driver} eq 'mysql') {
        $set = "CONCAT($new_escaped, SUBSTRING(Full_Name, $old_offset))";
    }
    elsif (lc $self->{connect}->{driver} eq 'pg') {
        $set = "$new_escaped || SUBSTRING(Full_Name, $old_offset)";
    }
    elsif (lc $self->{connect}->{driver} eq 'odbc' or lc $self->{connect}->{driver} eq 'mssql') {
        $set = "$new_escaped + SUBSTRING(Full_Name, $old_offset, 255)";
    }
    elsif (lc $self->{connect}->{driver} eq 'oracle') {
        $set = "$new_escaped || SUBSTR(Full_Name, $old_offset)";
    }

    if ($set) {
        $self->update(
            { Full_Name => \$set },
            { ID => \@children },
            { GT_SQL_SKIP_CHECK => 1 }
        );
    }
    else {
        my $sth = $self->select(qw/ID Full_Name/ => { ID => \@children });
        while (my ($id, $full_name) = $sth->fetchrow) {
            $full_name =~ s/^\Q$old/$new/ or next;
            $self->update({ Full_Name => $full_name }, { ID => $id }, { GT_SQL_SKIP_CHECK => 1 });
        }
    }
}

sub can_modify {
# -------------------------------------------------------------------
# Returns 1 if a record can be modified, undef otherwise.
#
    my ($self, $new, $orig) = @_;

# If the FatherID has changed, make sure the new father exists. If it's 0, then
# it's the root category and we don't worry about it.
    if ($orig->{FatherID} != $new->{FatherID} or $orig->{Name} ne $new->{Name}) {
        if ($orig->{FatherID} != $new->{FatherID} and $new->{FatherID}) {
            $self->count({ ID => $new->{FatherID} }) or return $self->error('BADCATID', 'WARN', $new->{FatherID});
        }
# Now make sure the new FatherID,Name doesn't exist as it must be unique.
        $self->count({ FatherID => $new->{FatherID}, Name => $new->{Name} }, GT::SQL::Condition->new(ID => '!=' => $orig->{ID})) and return $self->error('CATEXISTS', 'WARN', $new->{Name});
    }
    return 1;
}

sub template_set {
# -------------------------------------------------------------------
# Return the value of template set to use for a given category.
#
    my $self = shift;
    my $id   = shift or return $self->error('BADARGS', 'FATAL', "Must pass category id to template_set");
    return '' unless (exists $self->{schema}->{cols}->{Category_Template});

    return $self->{_template_cache}->{$id} if (exists $self->{_template_cache}->{$id});

# If this category has a template set, use it.
    my $cat_info = $self->select(Category_Template => { ID => $id })->fetchrow;

# Otherwise look at its parents.
    unless ($cat_info) {
        my $parents = $self->parents($id);
        for my $parent (@$parents) {
            $cat_info = $self->select(Category_Template => { ID => $parent })->fetchrow
                and last;
        }
    }
    $self->{_template_cache}->{$id} = $cat_info || '';
    return $self->{_template_cache}->{$id};
}

sub parents {
# -----------------------------------------------------------------------------
# Returns parent ID's given one or more category ID's.  If called with a single
# category ID, the return value is an array reference of the ID's of the
# category's parents, from father => root.  If called with an array reference
# of category ID's, the return value is a hash reference of
# (ID => [rootid ... parentid]) pairs, with one pair for each category.
#
    my $self = shift;
    my $id = shift or return $self->error('BADARGS', 'FATAL', "No category id passed to parents");

    my (%ret, @lookup);
    for (ref $id ? @$id : $id) {
        unless ($ret{$_} = $self->{_parent_cache}->{$_}) {
            push @lookup, $_;
        }
    }

    if (@lookup) {
        my $parents = $self->tree->parent_ids(id => \@lookup, include_dist => 1);
        for (@lookup) {
            $ret{$_} = $self->{_parent_cache}->{$_} = [sort { $parents->{$_}->{$b} <=> $parents->{$_}->{$a} } keys %{$parents->{$_}}];
        }
    }
    return ref $id
        ? \%ret
        : [reverse @{$ret{$id}}];
}

sub children {
# -----------------------------------------------------------------------------
# Exactly like parents(), except you get descendants rather than ancestors, and
# you get them in shallowest => deepest.
#
    my $self  = shift;
    my $id    = shift or return $self->error('BADARGS', 'FATAL', "No category id passed to children");

    my (%ret, @lookup);
    for (ref $id ? @$id : $id) {
        unless ($ret{$_} = $self->{_child_cache}->{$_}) {
            push @lookup, $_;
        }
    }

    if (@lookup) {
        my $children = $self->tree->child_ids(id => \@lookup, include_dist => 1);
        for (@lookup) {
            $ret{$_} = $self->{_child_cache}->{$_} = [sort { $children->{$_}->{$a} <=> $children->{$_}->{$b} } keys %{$children->{$_}}];
        }
    }
    return ref $id
        ? \%ret
        : $ret{$id};
}

sub suggestions {
# -----------------------------------------------------------------------------
# Returns a list of suggested category names. Takes a name and optional limit.
#
    my $self = shift;
    my $name = shift;
    $name =~ y/\r\n//d;
    $name =~ /\S/ or return [];

    $self->select_options('LIMIT 10');
    return [$self->select(Full_Name => GT::SQL::Condition->new(Full_Name => LIKE => "%$name%"))->fetchall_list];
}

sub link_count {
# -----------------------------------------------------------------------------
# Change the Number_of_Links count by n for specified id, and all parents.  You
# can pass multiple ID's by passing an array reference for ID.  You can pass
# both multiple change values by passing a hash reference of (CHANGE => [ID,
# ...]) pairs as the ID (the change value passed to the function will be
# ignored).  Note that Direct_Links counts are NOT changed.
#
    my ($self, $id, $change) = @_;

    my %id;
    if (!$id or ref $id eq 'ARRAY' and !@$id) {
        return;
    }
    elsif (ref $id eq 'HASH') {
        %id = %$id;
    }
    else {
        %id = ($change => ref $id ? $id : [$id]);
    }

    my %final;
    while (my ($change, $id) = each %id) {
        for (@$id) {
            $final{$_} = ($final{$_} || 0) + $change;
        }
        my $parents = $self->tree->parent_ids(id => $id);
        for my $parent (keys %$parents) {
            for (@{$parents->{$parent}}) {
                $final{$_} += $change;
            }
        }
    }

    my %change;
    for (keys %final) {
        push @{$change{$final{$_}}}, $_;
    }

    for (keys %change) {
        $self->update(
            { Number_of_Links => \('Number_of_Links' . ($_ > 0 ? ' + ' : ' - ') . abs) },
            { ID => $change{$_} },
            { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }
        );
    }
}

sub changed {
# -------------------------------------------------------------------
# Returns a statement handle that can be looped through to get a list
# of changed categories.
#
    Links::init_date();

    my $self = shift;
    my $date = GT::Date::date_get(defined $_[0] ? $_[0] : time);
    my $sth  = $self->select(GT::SQL::Condition->new(Timestmp => '>=' => $date ));
    return $sth;
}

sub get_id_from_name {
# -------------------------------------------------------------------
# Returns the category id based on the name.
#
    my ($self, $name) = @_;
    $name =~ y/\r\n//d;
    $name =~ /\S/ or return;

    return $self->{_id_cache}->{$name} if exists $self->{_id_cache}->{$name};
    $self->{_id_cache}->{$name} = $self->select(ID => { Full_Name => $name })->fetchrow_array;
    return $self->{_id_cache}->{$name};
}

sub get_name_from_id {
# -------------------------------------------------------------------
# Returns the category full name based on the id.
#
    my ($self, $id) = @_;
    return $self->{_name_cache}->{$id} if exists $self->{_name_cache}->{$id};
    return $self->{_name_cache}->{$id} = $self->select(Full_Name => { ID => $id })->fetchrow;
}


sub as_url {
# -------------------------------------------------------------------
#
    my ($self, $name, $format) = @_;
    return $PLG->dispatch('category_as_url', sub { return $self->_as_url(@_) }, $name, $format);
}

sub _as_url {
# -------------------------------------------------------------------
# Return the passed-in category name as a formatted category path, usable for
# static templates.
#
    my ($self, $name, $format) = @_;

    my $cat = $self->select({ Full_Name => $name })->fetchrow_hashref
        or return $name;
    require Links::Tools;
    $format ||= $IN->param('d') ? $CFG->{build_category_dynamic} ? "%$CFG->{build_category_dynamic}%" : '' : $CFG->{build_category_format};
    $format ||= '%Full_Name%';
    if ($format eq '%Full_Name%' and ($IN->param('d') or $CFG->{build_format_compat})) {
        # Old Links SQL's (prior to configurable category naming) didn't
        # coalesce multiple _'s into a single _, and dynamic mode still depends
        # on that behaviour - so if the format is just Full_Name, mimic the old
        # behaviour.
        (my $ret = $cat->{Full_Name}) =~ y|a-zA-Z0-9_/-|_|c;
        return $ret;
    }
    if ($format =~ /%Full_ID%/) {
        $cat->{Full_ID} = join '/', (@{$self->tree->parent_ids(id => $cat->{ID})}, $cat->{ID});
    }
    return Links::Tools::parse_format(
        $format,
        %$cat,
        clean => 1
    );
}

sub set_new {
# -------------------------------------------------------------------
# Sets the new flag for a given category id (or list).
#
    my $self = shift;
    my @ids  = ref $_[0] eq 'ARRAY' ? @{shift()} : shift;
    my $rel  = $DB->table('Links', 'CatLinks', 'Category');
    for my $id (@ids) {
        my $parents = $self->parents($id);
        my @pids    = reverse @$parents;
        push @pids, $id;

        for my $pid (@pids) {
            my $children = $self->children($pid);
            $rel->select_options('GROUP BY Add_Date');
            my $sth = $rel->select(qw/MAX(Add_Date) isNew/ => GT::SQL::Condition->new(
                CategoryID => '=' => [$pid, @$children],
                VIEWABLE
            ));
            my ($newest, $new) = $sth->fetchrow;
            $self->update(
                { Has_New_Links => $new || 'No', Newest_Link => $newest },
                { ID => $pid },
                { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }
            );
        }
    }
}

sub _clear_cache {
# -------------------------------------------------------------------
# Clear out cache results whenever a category is added/deleted/changed.
#
    my $self = shift;
    delete @$self{qw{_parent_cache _child_cache _name_cache _id_cache _template_cache}};
    return 1;
}

1;
