koha-dev.rot13.org Git - srvgit/blob - 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     my $dbh = C4::Context->dbh;
  72     my $sth = $dbh->prepare(
  73         "SELECT tagfield, authtypecode
  74          FROM marc_subfield_structure
  75          WHERE frameworkcode = '' AND authtypecode <> ''"
  76     );
  77     $sth->execute();
  78     $bib_heading_fields = {};
  79     while ( my ( $tag, $auth_type ) = $sth->fetchrow ) {
  80         $bib_heading_fields->{$tag} = {
  81             auth_type => $auth_type,
  82             subfields => 'abcdefghjklmnopqrstvxyz',
  83         };
  84     }
  85
  86     return bless {}, $class;
  87 }
  88
  89 =head2 valid_heading_tag
  90
  91 =cut
  92
  93 sub valid_heading_tag {
  94     my ( $self, $tag ) = @_;
  95     return $bib_heading_fields->{$tag};
  96 }
  97
  98 =head2 valid_heading_subfield
  99
 100 =cut
 101
 102 sub valid_heading_subfield {
 103     my $self          = shift;
 104     my $tag           = shift;
 105     my $subfield      = shift;
 106
 107     if ( exists $bib_heading_fields->{$tag} ) {
 108         return 1 if ($bib_heading_fields->{$tag}->{subfields} =~ /$subfield/);
 109     }
 110     return 0;
 111 }
 112
 113 =head2 parse_heading
 114
 115 =cut
 116
 117 sub parse_heading {
 118     my ( $self, $field ) = @_;
 119
 120     my $tag        = $field->tag;
 121     my $field_info = $bib_heading_fields->{$tag};
 122     my $auth_type  = $field_info->{'auth_type'};
 123     my $search_heading =
 124       _get_search_heading( $field, $field_info->{'subfields'} );
 125     my $display_heading =
 126       _get_display_heading( $field, $field_info->{'subfields'} );
 127
 128     return ( $auth_type, undef, $search_heading, $display_heading, 'exact' );
 129 }
 130
 131 =head1 INTERNAL FUNCTIONS
 132
 133 =head2 _get_subject_thesaurus
 134
 135 =cut
 136
 137 sub _get_subject_thesaurus {
 138     my $field = shift;
 139
 140     my $thesaurus = "notdefined";
 141     my $sf2       = $field->subfield('2');
 142     $thesaurus = $sf2 if defined($sf2);
 143
 144     return $thesaurus;
 145 }
 146
 147 =head2 _get_search_heading
 148
 149 =cut
 150
 151 sub _get_search_heading {
 152     my $field     = shift;
 153     my $subfields = shift;
 154
 155     my $heading   = "";
 156     my @subfields = $field->subfields();
 157     my $first     = 1;
 158     for ( my $i = 0 ; $i <= $#subfields ; $i++ ) {
 159         my $code    = $subfields[$i]->[0];
 160         my $code_re = quotemeta $code;
 161         my $value   = $subfields[$i]->[1];
 162         $value =~ s/[\s]*[-,.:=;!%\/][\s]*$//;
 163         next unless $subfields =~ qr/$code_re/;
 164         if ($first) {
 165             $first   = 0;
 166             $heading = $value;
 167         }
 168         else {
 169             if ( exists $subdivisions{$code} ) {
 170                 $heading .= " $subdivisions{$code} $value";
 171             }
 172             else {
 173                 $heading .= " $value";
 174             }
 175         }
 176     }
 177
 178     # remove characters that are part of CCL syntax
 179     $heading =~ s/[)(=]//g;
 180
 181     return $heading;
 182 }
 183
 184 =head2 _get_display_heading
 185
 186 =cut
 187
 188 sub _get_display_heading {
 189     my $field     = shift;
 190     my $subfields = shift;
 191
 192     my $heading   = "";
 193     my @subfields = $field->subfields();
 194     my $first     = 1;
 195     for ( my $i = 0 ; $i <= $#subfields ; $i++ ) {
 196         my $code    = $subfields[$i]->[0];
 197         my $code_re = quotemeta $code;
 198         my $value   = $subfields[$i]->[1];
 199         next unless $subfields =~ qr/$code_re/;
 200         if ($first) {
 201             $first   = 0;
 202             $heading = $value;
 203         }
 204         else {
 205             if ( exists $subdivisions{$code} ) {
 206                 $heading .= "--$value";
 207             }
 208             else {
 209                 $heading .= " $value";
 210             }
 211         }
 212     }
 213     return $heading;
 214 }
 215
 216 =head1 AUTHOR
 217
 218 Koha Development Team <http://koha-community.org/>
 219
 220 Jared Camins-Esakov <jcamins@cpbibliography.com>
 221
 222 =cut
 223
 224 1;