C4/Heading/UNIMARC.pm

   1 package C4::Heading::UNIMARC;
   2
   3 # Copyright (C) 2011 C & P Bibliography Services
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use 5.010;
  21 use strict;
  22 use warnings;
  23 use MARC::Field;
  24 use C4::Context;
  25
  26
  27 =head1 NAME
  28
  29 C4::Heading::UNIMARC
  30
  31 =head1 SYNOPSIS
  32
  33 use C4::Heading::UNIMARC;
  34
  35 =head1 DESCRIPTION
  36
  37 This is an internal helper class used by
  38 C<C4::Heading> to parse headings data from
  39 UNIMARC records.  Object of this type
  40 do not carry data, instead, they only
  41 dispatch functions.
  42
  43 =head1 DATA STRUCTURES
  44
  45 FIXME - this should be moved to a configuration file.
  46
  47 =head2 subdivisions
  48
  49 =cut
  50
  51 my %subdivisions = (
  52     'j' => 'formsubdiv',
  53     'x' => 'generalsubdiv',
  54     'y' => 'geographicsubdiv',
  55     'z' => 'chronologicalsubdiv',
  56 );
  57
  58 my $bib_heading_fields;
  59
  60 =head1 METHODS
  61
  62 =head2 new
  63
  64   my $marc_handler = C4::Heading::UNIMARC->new();
  65
  66 =cut
  67
  68 sub new {
  69     my $class = shift;
  70
  71     unless ( defined $bib_heading_fields ) {
  72         my $dbh = C4::Context->dbh;
  73         my $sth = $dbh->prepare(
  74             "SELECT tagfield, authtypecode
  75              FROM marc_subfield_structure
  76              WHERE frameworkcode = '' AND authtypecode <> ''"
  77         );
  78         $sth->execute();
  79         $bib_heading_fields = {};
  80         while ( my ( $tag, $auth_type ) = $sth->fetchrow ) {
  81             $bib_heading_fields->{$tag} = {
  82                 auth_type => $auth_type,
  83                 subfields => 'abcdefghjklmnopqrstvxyz',
  84             };
  85         }
  86     }
  87
  88     return bless {}, $class;
  89 }
  90
  91 =head2 valid_heading_tag
  92
  93 =cut
  94
  95 sub valid_heading_tag {
  96     my ( $self, $tag ) = @_;
  97     return $bib_heading_fields->{$tag};
  98 }
  99
 100 =head2 valid_heading_subfield
 101
 102 =cut
 103
 104 sub valid_heading_subfield {
 105     my $self          = shift;
 106     my $tag           = shift;
 107     my $subfield      = shift;
 108
 109     if ( exists $bib_heading_fields->{$tag} ) {
 110         return 1 if ($bib_heading_fields->{$tag}->{subfields} =~ /$subfield/);
 111     }
 112     return 0;
 113 }
 114
 115 =head2 parse_heading
 116
 117 =cut
 118
 119 sub parse_heading {
 120     my ( $self, $field ) = @_;
 121
 122     my $tag        = $field->tag;
 123     my $field_info = $bib_heading_fields->{$tag};
 124     my $auth_type  = $field_info->{'auth_type'};
 125     my $search_heading =
 126       _get_search_heading( $field, $field_info->{'subfields'} );
 127     my $display_heading =
 128       _get_display_heading( $field, $field_info->{'subfields'} );
 129
 130     return ( $auth_type, undef, $search_heading, $display_heading, 'exact' );
 131 }
 132
 133 =head1 INTERNAL FUNCTIONS
 134
 135 =head2 _get_subject_thesaurus
 136
 137 =cut
 138
 139 sub _get_subject_thesaurus {
 140     my $field = shift;
 141
 142     my $thesaurus = "notdefined";
 143     my $sf2       = $field->subfield('2');
 144     $thesaurus = $sf2 if defined($sf2);
 145
 146     return $thesaurus;
 147 }
 148
 149 =head2 _get_search_heading
 150
 151 =cut
 152
 153 sub _get_search_heading {
 154     my $field     = shift;
 155     my $subfields = shift;
 156
 157     my $heading   = "";
 158     my @subfields = $field->subfields();
 159     my $first     = 1;
 160     for ( my $i = 0 ; $i <= $#subfields ; $i++ ) {
 161         my $code    = $subfields[$i]->[0];
 162         my $code_re = quotemeta $code;
 163         my $value   = $subfields[$i]->[1];
 164         $value =~ s/[\s]*[-,.:=;!%\/][\s]*$//;
 165         next unless $subfields =~ qr/$code_re/;
 166         if ($first) {
 167             $first   = 0;
 168             $heading = $value;
 169         }
 170         else {
 171             if ( exists $subdivisions{$code} ) {
 172                 $heading .= " $subdivisions{$code} $value";
 173             }
 174             else {
 175                 $heading .= " $value";
 176             }
 177         }
 178     }
 179
 180     # remove characters that are part of CCL syntax
 181     $heading =~ s/[)(=]//g;
 182
 183     return $heading;
 184 }
 185
 186 =head2 _get_display_heading
 187
 188 =cut
 189
 190 sub _get_display_heading {
 191     my $field     = shift;
 192     my $subfields = shift;
 193
 194     my $heading   = "";
 195     my @subfields = $field->subfields();
 196     my $first     = 1;
 197     for ( my $i = 0 ; $i <= $#subfields ; $i++ ) {
 198         my $code    = $subfields[$i]->[0];
 199         my $code_re = quotemeta $code;
 200         my $value   = $subfields[$i]->[1];
 201         next unless $subfields =~ qr/$code_re/;
 202         if ($first) {
 203             $first   = 0;
 204             $heading = $value;
 205         }
 206         else {
 207             if ( exists $subdivisions{$code} ) {
 208                 $heading .= "--$value";
 209             }
 210             else {
 211                 $heading .= " $value";
 212             }
 213         }
 214     }
 215     return $heading;
 216 }
 217
 218 =head1 AUTHOR
 219
 220 Koha Development Team <http://koha-community.org/>
 221
 222 Jared Camins-Esakov <jcamins@cpbibliography.com>
 223
 224 =cut
 225
 226 1;