- 

#!/usr/bin/perl

# Copyright 2024 Hypernova Oy

#

# This file is part of Koha.

#

# Koha 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 3 of the License, or

# (at your option) any later version.

#

# Koha is distributed in the hope that it will be useful, but

# WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

# GNU General Public License for more details.

#

# You should have received a copy of the GNU General Public License

# along with Koha; if not, see <http://www.gnu.org/licenses>.

use Modern::Perl;

use strict;

use warnings;

use Getopt::Long qw( GetOptions :config no_ignore_case bundling);

use Data::Printer;

use Pod::Usage qw( pod2usage );

use Koha::Database;

=head1 NAME

marc_framework_diff.pl - Detect differences in MARC frameworks and reconcile them

=head1 SYNOPSIS

marc_framework_diff.pl

 Options:

  --help or -h          Brief usage message

  --verbose or -v       Integer, 0-4, Be more verbose

 Utility commands

  --list-frameworkcodes List all framework codes in Koha as a csv, with more

                        verbosity dumps object attributes.

 Diff commands

  --diff                Activate diffing output. By default selects all

                        frameworks for diffing.

  --attributes-exclude  CSV String, eg. "display_order,maxlength".

                        Exclude these marc framework keys from comparison.

  --frameworks-include  CSV String, eg. "ACQ,,FA,BKS"

                        (Empty ,, selects the default framework).

                        Include these frameworks.

  --frameworks-exclude  CSV String, eg. "ACQ,FA"

                        (Empty ,, selects the default framework).

                        Exclude these frameworks. Can be used with

                        --frameworks-include

  --ignore-undef        When comparing values, undefined and "" and 0 compare

                        as equally undefined/unset/false.

  --perly-false         When comparing values, "" and 0 compare

                        as equally undefined/unset/false.

 Update commands

  --update              Activate the update feature.

  --field               String, eg. "245". MARC field within the framework.

  --subfield            String, eg. "a". MARC subfield within the framework.

  --attribute           String, eg. "hidden". Framework attribute to update.

  --value               String, eg. "yso_finto_finaf.pl".

                        Value to set to all of the selected frameworks.

=head1 EXAMPLES

 marc_framework_diff.pl --list-frameworkcodes -v 1

 # Update marc frameworks "KI,,KA,EK" field "810$t" attribute "hidden" with "0"

 marc_framework_diff.pl --diff --attributes-exclude "display_order,maxlength" \

  --frameworks-include "KI,,KA,EK" --ignore-undef --perly-false \

  --update --field 810 --subfield t --attribute hidden --value 0

=cut

binmode( STDOUT, ":encoding(UTF-8)" );

my %a;

GetOptions(

  \%a,

  'help|h',

  'verbose|v:i',

  #Utility commands

  'list-frameworkcodes',

  #Diff commands

  'diff',

  'attributes-exclude:s',

  'frameworks-include:s',

  'frameworks-exclude:s',

  'ignore-undef',

  'perly-false',

  #Update commands

  'update',

  'field:s',

  'subfield:s',

  'attribute:s',

  'value:s',

) or pod2usage(2);

$a{verbose} = 0 unless exists $a{verbose};

p(%a);

pod2usage(1) if $a{help};

my $dbh = Koha::Database->schema->storage->dbh(); # Use DBD::MySQL for minimum headache

$dbh->{ShowErrorStatement} = 1;

$dbh->{RaiseError} = 1;

my @colWidths = (3, 1, 16, 30);

sub col {

  my ($position, $value) = @_;

  my $width = $colWidths[$position];

  my $offset = $width - length($value);

  return $value . (" " x $offset) if $offset > 0;

  return substr($value, 0, $width);

}

sub handle_cli_param_include_exclude {

  my ($biblio_framework_codes) = @_;

  if ($a{'attributes-exclude'}) {

    $a{'attributes-exclude'} =~ s/\s//gsm;

    $a{'attributes-exclude'} = ','.$a{'attributes-exclude'}.',';

    if ($a{verbose} > 1) {

      print "- Attributes to exclude: $a{'attributes-exclude'}\n";

    }

  }

  if ($a{'frameworks-include'}) {

    $a{'frameworks-include'} =~ s/\s//gsm;

    $a{'frameworks-include'} = ','.$a{'frameworks-include'}.',';

    @$biblio_framework_codes = grep {$a{'frameworks-include'} =~ /,$_,/} @$biblio_framework_codes;

    if ($a{verbose} > 1) {

      print "- Included: @$biblio_framework_codes\n";

    }

  }

  if ($a{'frameworks-exclude'}) {

    $a{'frameworks-exclude'} =~ s/\s//gsm;

    $a{'frameworks-exclude'} = ','.$a{'frameworks-exclude'}.',';

    @$biblio_framework_codes = grep {$a{'frameworks-exclude'} !~ /,$_,/} @$biblio_framework_codes;

    if ($a{verbose} > 1) {

      print "- Excluded: @$biblio_framework_codes\n";

    }

  }

  return $biblio_framework_codes;

}

sub _check_where_filter {

  my ($sql_where_filter) = @_;

  $sql_where_filter = "" unless $sql_where_filter;

  $sql_where_filter = "WHERE $sql_where_filter" if $sql_where_filter and $sql_where_filter !~ /WHERE/;

  return $sql_where_filter;

}

sub fetch_biblio_framework_codes {

  my $sql = "SELECT DISTINCT(frameworkcode) FROM biblio_framework ORDER BY frameworkcode ASC;";

  print "SQL:> " . sql_dump($sql) . "\n" if $a{verbose};

  my $biblio_framework_codes = $dbh->selectcol_arrayref($sql);

  push(@$biblio_framework_codes, ''); #The default framework is no longer in the biblio_frameworks-table

  return $biblio_framework_codes;

}

sub fetch_biblio_frameworks {

  my ($sql_where_filter) = @_;

  $sql_where_filter = _check_where_filter($sql_where_filter);

  my $sql = "SELECT * FROM biblio_framework $sql_where_filter ORDER BY frameworkcode ASC;";

  print "SQL:> " . sql_dump($sql) . "\n" if $a{verbose};

  my $biblio_frameworks = $dbh->selectall_arrayref($sql, { Slice => {} });

  push(@$biblio_frameworks, {frameworkcode => '', frameworktext => 'Default'}) if $sql_where_filter =~ /''/; #The default framework is no longer in the biblio_frameworks-table

  return $biblio_frameworks;

}

sub fetch_marc_tag_structure {

  my ($sql_where_filter) = @_;

  $sql_where_filter = _check_where_filter($sql_where_filter);

  my $sql = "SELECT * FROM marc_tag_structure $sql_where_filter GROUP BY frameworkcode ASC, tagfield ASC;";

  print "SQL:> " . sql_dump($sql) . "\n" if $a{verbose};

  return $dbh->selectall_arrayref($sql, { Slice => {} });

}

sub fetch_marc_subfield_structure {

  my ($sql_where_filter) = @_;

  $sql_where_filter = _check_where_filter($sql_where_filter);

  my $sql = "SELECT * FROM marc_subfield_structure $sql_where_filter GROUP BY frameworkcode ASC, tagfield ASC, tagsubfield ASC;";

  print "SQL:> " . sql_dump($sql) . "\n" if $a{verbose};

  return $dbh->selectall_arrayref($sql, { Slice => {} });

}

sub fetch_data {

  my $biblio_framework_codes = fetch_biblio_framework_codes();

  $biblio_framework_codes = handle_cli_param_include_exclude($biblio_framework_codes);

  my $sql_where_filter = "WHERE frameworkcode IN ('" . join("','", @$biblio_framework_codes) . "')";

  my $biblio_frameworks = fetch_biblio_frameworks($sql_where_filter);

  if ($a{verbose} > 1) {

    print "Biblio frameworks:\n";

    p($biblio_frameworks);

  }

  my $marc_field_structure = fetch_marc_tag_structure($sql_where_filter);

  if ($a{verbose} > 3) { # This is too massive info dump

    print "MARC field structure:\n";

    p($marc_field_structure);

  }

  my $marc_subfield_structure = fetch_marc_subfield_structure($sql_where_filter);

  if ($a{verbose} > 3) { # This is too massive info dump

    print "MARC subfield structure:\n";

    p($marc_subfield_structure);

  }

  my $distinct_fields_and_subfields = $dbh->selectall_arrayref("SELECT tagfield, tagsubfield FROM marc_subfield_structure $sql_where_filter GROUP BY tagfield, tagsubfield ORDER BY tagfield ASC, tagsubfield ASC", { Slice => {} });

  if ($a{verbose} > 3) {

    print "distinct_fields_and_subfields:\n";

    p($distinct_fields_and_subfields);

  }

  return ($biblio_frameworks, $marc_field_structure, $marc_subfield_structure, $distinct_fields_and_subfields);

}

sub prepare_data_for_comparison {

  my ($biblio_frameworks, $marc_field_structure, $marc_subfield_structure, $distinct_fields_and_subfields) = @_;

  my $d = MFWDiff->new();

  for my $fw (@$biblio_frameworks) {

    $d->add_framework($fw);

  }

  for my $dfsfs (@$distinct_fields_and_subfields) {

    $d->push_comparison_slots($dfsfs->{tagfield}, $dfsfs->{tagsubfield});

  }

  for my $mfs (@$marc_field_structure) {

    $d->push_field_structure($mfs->{tagfield}, $mfs);

  }

  for my $mss (@$marc_subfield_structure) {

    $d->push_subfield_structure($mss->{tagfield}, $mss->{tagsubfield}, $mss);

  }

  return $d;

}

sub diff_comparison {

  my ($d) = @_;

  for my $field_code (sort keys %{$d->{fields}}) {

    for my $attr (sort keys %{$d->{fields}->{$field_code}->{attr}}) {

      for my $fw_seek ($d->get_framework_codes()) {

        for my $fw_comp ($d->get_framework_codes()) {

          next if ($fw_seek eq $fw_comp);

          next if ($attr eq 'frameworkcode');

          next if ($a{'attributes-exclude'} && $a{'attributes-exclude'} =~ /$attr/);

          if ($d->field_values_diff($field_code, $attr, $fw_seek, $fw_comp)) {

            $d->add_field_diff($field_code, $attr, $fw_seek, $fw_comp);

          }

        }

      }

    }

    for my $subfield_code (sort keys %{$d->{fields}->{$field_code}->{subs}}) {

      for my $attr (sort keys %{$d->{fields}->{$field_code}->{subs}->{$subfield_code}}) {

        for my $fw_seek ($d->get_framework_codes()) {

          for my $fw_comp ($d->get_framework_codes()) {

            next if ($fw_seek eq $fw_comp);

            next if ($attr eq 'frameworkcode');

            next if ($a{'attributes-exclude'} && $a{'attributes-exclude'} =~ /$attr/);

            if ($d->subfield_values_diff($field_code, $subfield_code, $attr, $fw_seek, $fw_comp)) {

              $d->add_subfield_diff($field_code, $subfield_code, $attr, $fw_seek, $fw_comp);

            }

          }

        }

      }

    }

  }

  return $d;

}

sub print_diff {

  my ($d) = @_;

  print "|" . join("|", col(0, "FLD"), col(1, "S"), col(2, "Attribute")) . "|";

  for my $fw ($d->get_framework_codes()) {

    print col(3, ($fw ? $fw : 'Default')) . "|";

  }

  print "\n+---+-+-----------+-------------------------------\n";

  for my $field_code (sort keys %{$d->{fields}}) {

    for my $attr (sort keys %{$d->{fields}->{$field_code}->{attr}}) {

      my $show_diff = 0;

      my @sb;

      for my $fw ($d->get_framework_codes()) {

        if ($d->{fields}->{$field_code}->{attr}->{$attr}->{$fw}->{diff}) {

          $show_diff++;

          push(@sb, col(3, scalar(@{$d->{fields}->{$field_code}->{attr}->{$attr}->{$fw}->{diff}}) . '*' . $d->field_value($field_code, $attr, $fw)));

        }

        else {

          push(@sb, col(3, ""));

        }

      }

      print "|" . join("|", col(0, $field_code), col(1, " "), col(2, $attr)) . "|" . join("|", @sb) . "|\n" if $show_diff;

    }

    for my $subfield_code (sort keys %{$d->{fields}->{$field_code}->{subs}}) {

      for my $attr (sort keys %{$d->{fields}->{$field_code}->{subs}->{$subfield_code}}) {

        my $show_diff = 0;

        my @sb;

        for my $fw ($d->get_framework_codes()) {

          if ($d->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attr}->{$fw}->{diff}) {

            $show_diff++;

            push(@sb, col(3, scalar(@{$d->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attr}->{$fw}->{diff}}) . '*' . $d->subfield_value($field_code, $subfield_code, $attr, $fw)));

          }

          else {

            push(@sb, col(3, ""));

          }

        }

        print "|" . join("|", col(0, $field_code), col(1, $subfield_code), col(2, $attr)) . "|" . join("|", @sb) . "|\n" if $show_diff;

      }

    }

  }

}

sub list_frameworkcodes {

  if ($a{verbose} == 0) {

    my $biblio_framework_codes = fetch_biblio_framework_codes();

    print join(",", @$biblio_framework_codes)."\n";

  }

  else {

    my $biblio_frameworks = fetch_biblio_frameworks("");

    p($biblio_frameworks);

  }

}

sub sql_dump {

  my ($sql, @params) = @_;

  $sql . ' "' . join('","', @params) . '"';

}

sub update {

  my $biblio_framework_codes = fetch_biblio_framework_codes();

  $biblio_framework_codes = handle_cli_param_include_exclude($biblio_framework_codes);

  my $sql_frameworkcode_filter = "frameworkcode IN ('" . join("','", @$biblio_framework_codes) . "')";

  my $rv;

  my $sql;

  if ($a{field} && not($a{subfield})) {

    $sql = "UPDATE marc_tag_structure SET ".$dbh->quote_identifier($a{attribute})." = ? WHERE $sql_frameworkcode_filter AND tagfield = ?;";

    print "SQL:> " . sql_dump($sql, $a{value}, $a{field}) . "\n" if $a{verbose};

    $rv = $dbh->do($sql, undef, $a{value}, $a{field});

  }

  elsif ($a{field} && $a{subfield}) {

    $sql = "UPDATE marc_subfield_structure SET ".$dbh->quote_identifier($a{attribute})." = ? WHERE $sql_frameworkcode_filter AND tagfield = ? AND tagsubfield = ?;";

    print "SQL:> " . sql_dump($sql, $a{value}, $a{field}, $a{subfield}) . "\n" if $a{verbose};

    $rv = $dbh->do($sql, undef, $a{value}, $a{field}, $a{subfield});

  }

  print "SQL:> $rv rows affected\n" if ($rv >= 0);

}

list_frameworkcodes() if $a{'list-frameworkcodes'};

update() if $a{update};

print_diff(diff_comparison(prepare_data_for_comparison(fetch_data()))) if $a{diff};

package MFWDiff;

=head2 MFWDiff

Data structure to present all the frameworks in a easily comparable fashion.

field -> 'attr' -> attribute -> framework -> 'value' -> value

                                          -> 'diff'  -> [framework, framework, ...]

         'subs' -> subfield -> attribute -> framework -> 'value' -> value

                                                      -> 'diff'  -> [framework, framework, ...]

=cut

sub new {

  my $self = {};

  return bless($self, $_[0]);

}

sub field {

  return $_[0]->{fields}->{$_[1]};

}

sub field_value {

  my ($s, $field_code, $attribute, $frameworkcode) = @_;

  #return '_mssin_' unless $s->{fields}->{$field_code}->{attr}->{$attribute}->{$frameworkcode};

  return '_mssin_' unless $s->{fields}->{$field_code}->{attr}->{$attribute}->{$frameworkcode}->{value};

  return $s->{fields}->{$field_code}->{attr}->{$attribute}->{$frameworkcode}->{value};

}

sub subfield_value {

  my ($s, $field_code, $subfield_code, $attribute, $frameworkcode) = @_;

  #return '_mssin_' unless $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attribute}->{$frameworkcode};

  return '_mssin_' unless $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attribute}->{$frameworkcode}->{value};

  return $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attribute}->{$frameworkcode}->{value};

}

sub add_field_diff {

  my ($s, $field_code, $attribute, $frameworkcode_seeker, $frameworkcode_comparator) = @_;

  $s->{fields}->{$field_code}->{attr}->{$attribute}->{$frameworkcode_seeker}->{diff} = [] unless $s->{fields}->{$field_code}->{attr}->{$attribute}->{$frameworkcode_seeker}->{diff};

  push(@{$s->{fields}->{$field_code}->{attr}->{$attribute}->{$frameworkcode_seeker}->{diff}}, $frameworkcode_comparator);

  print("Diff: '$field_code'->'attr'->'$attribute'->'$frameworkcode_seeker' ne '$frameworkcode_comparator'\n") if $a{verbose} > 1;

}

sub add_subfield_diff {

  my ($s, $field_code, $subfield_code, $attribute, $frameworkcode_seeker, $frameworkcode_comparator) = @_;

  $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attribute}->{$frameworkcode_seeker}->{diff} = [] unless $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attribute}->{$frameworkcode_seeker}->{diff};

  push(@{$s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attribute}->{$frameworkcode_seeker}->{diff}}, $frameworkcode_comparator);

  print("Diff: '$field_code\$$subfield_code'->'attr'->'$attribute'->'$frameworkcode_seeker' ne '$frameworkcode_comparator'\n") if $a{verbose} > 1;

}

sub field_values_diff {

  my ($s, $field_code, $attr, $fw_seek, $fw_comp) = @_;

  if ($a{'perly-false'}) {

    return 0 if (not($s->{fields}->{$field_code}->{attr}->{$attr}->{$fw_seek}->{value}) && not($s->{fields}->{$field_code}->{attr}->{$attr}->{$fw_comp}->{value}));

  }

  return $s->field_value($field_code, $attr, $fw_seek) ne $s->field_value($field_code, $attr, $fw_comp);

}

sub subfield_values_diff {

  my ($s, $field_code, $subfield_code, $attr, $fw_seek, $fw_comp) = @_;

  if ($a{'perly-false'}) {

    return 0 if (not($s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attr}->{$fw_seek}->{value}) && not($s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$attr}->{$fw_comp}->{value}));

  }

  return $s->subfield_value($field_code, $subfield_code, $attr, $fw_seek) ne $s->subfield_value($field_code, $subfield_code, $attr, $fw_comp);

}

sub push_comparison_slots {

  my ($s, $field_code, $subfield_code) = @_;

  $s->{fields}->{$field_code} = {} unless $s->{fields}->{$field_code};

  $s->{fields}->{$field_code}->{attr} = {} unless $s->{fields}->{$field_code}->{attr};

  $s->{fields}->{$field_code}->{subs} = {} unless $s->{fields}->{$field_code}->{subs};

  $s->{fields}->{$field_code}->{subs}->{$subfield_code} = {};

}

sub push_field_structure {

  my ($s, $field_code, $mfs) = @_;

  unless ($s->{fields}->{$field_code}) {

    warn "push_field_structure($field_code fw='".$mfs->{frameworkcode}."'):> Missing field_code?";

  }

  while (my ($k, $v) = each(%$mfs)) {

    $s->{fields}->{$field_code}->{attr}->{$k} = {} unless $s->{fields}->{$field_code}->{attr}->{$k};

    $s->{fields}->{$field_code}->{attr}->{$k}->{$mfs->{frameworkcode}} = {} unless $s->{fields}->{$field_code}->{attr}->{$k}->{$mfs->{frameworkcode}};

    if ($a{'ignore-undef'} || $a{'perly-false'}) {

      $s->{fields}->{$field_code}->{attr}->{$k}->{$mfs->{frameworkcode}}->{value} = (defined $v) ? $v : '';

    }

    else {

      $s->{fields}->{$field_code}->{attr}->{$k}->{$mfs->{frameworkcode}}->{value} = (defined $v) ? $v : '_undef_';

    }

  }

}

sub push_subfield_structure {

  my ($s, $field_code, $subfield_code, $mss) = @_;

  unless ($s->{fields}->{$field_code}) {

    warn "push_subfield_structure($field_code\$$subfield_code fw='".$mss->{frameworkcode}."'):> Missing field_code?";

  }

  unless ($s->{fields}->{$field_code}->{subs}->{$subfield_code}) {

    warn "push_subfield_structure($field_code\$$subfield_code fw='".$mss->{frameworkcode}."'):> Missing subfield_code?";

  }

  while (my ($k, $v) = each(%$mss)) {

    $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$k} = {} unless $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$k};

    $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$k}->{$mss->{frameworkcode}} = {} unless $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$k}->{$mss->{frameworkcode}};

    if ($a{'ignore-undef'} || $a{'perly-false'}) {

      $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$k}->{$mss->{frameworkcode}}->{value} = (defined $v) ? $v : '';

    }

    else {

      $s->{fields}->{$field_code}->{subs}->{$subfield_code}->{$k}->{$mss->{frameworkcode}}->{value} = (defined $v) ? $v : '_undef_';

    }

  }

}

sub add_framework {

  my ($s, $framework) = @_;

  $s->{frameworks} = {} unless $s->{frameworks};

  $s->{frameworks}->{$framework->{frameworkcode}} = $framework;

}

# Use en external frameworks list, because not all frameworks have all fields/subfields

sub get_framework_codes {

  return sort keys %{$_[0]->{frameworks}};

}