View | Details | Raw Unified | Return to bug 6113
Collapse All | Expand All

(-)a/t/db_dependent/PreserveLegacyId.t (-1 / +150 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
#
3
# This Koha test module is a stub!  
4
# Add more tests here!!!
5
6
use Modern::Perl;
7
use utf8;
8
9
use Test::More tests => 3;
10
use MARC::Record;
11
12
BEGIN {
13
        use_ok('C4::Record');
14
        use_ok('C4::Biblio');
15
}
16
17
### Preparing our testing data ###
18
my $bibFramework = ''; #Using the default bibliographic framework.
19
my $marcxml=qq(<?xml version="1.0" encoding="UTF-8"?>
20
<record format="MARC21" type="Bibliographic">
21
  <leader>00000cim a22000004a 4500</leader>
22
  <controlfield tag="001">1001</controlfield>
23
  <controlfield tag="005">2013-06-03 07:04:07+02</controlfield>
24
  <controlfield tag="007">ss||||j|||||||</controlfield>
25
  <controlfield tag="008">       uuuu    xxk|||||||||||||||||eng|c</controlfield>
26
  <datafield tag="020" ind1=" " ind2=" ">
27
    <subfield code="a">0-00-103147-3</subfield>
28
    <subfield code="c">14.46 EUR</subfield>
29
  </datafield>
30
  <datafield tag="041" ind1="0" ind2=" ">
31
    <subfield code="d">eng</subfield>
32
  </datafield>
33
  <datafield tag="084" ind1=" " ind2=" ">
34
    <subfield code="a">83.5</subfield>
35
    <subfield code="2">ykl</subfield>
36
  </datafield>
37
  <datafield tag="100" ind1="1" ind2=" ">
38
    <subfield code="a">SHAKESPEARE, WILLIAM.</subfield>
39
  </datafield>
40
  <datafield tag="245" ind1="1" ind2="4">
41
    <subfield code="a">THE TAMING OF THE SHREW /</subfield>
42
    <subfield code="c">WILLIAM SHAKESPEARE</subfield>
43
    <subfield code="h">[ÄÄNITE].</subfield>
44
  </datafield>
45
  <datafield tag="260" ind1=" " ind2=" ">
46
    <subfield code="a">LONDON :</subfield>
47
    <subfield code="b">COLLINS.</subfield>
48
  </datafield>
49
  <datafield tag="300" ind1=" " ind2=" ">
50
    <subfield code="a">2 ÄÄNIKASETTIA.</subfield>
51
  </datafield>
52
  <datafield tag="852" ind1=" " ind2=" ">
53
    <subfield code="a">FI-Jm</subfield>
54
    <subfield code="h">83.5</subfield>
55
  </datafield>
56
  <datafield tag="852" ind1=" " ind2=" ">
57
    <subfield code="a">FI-Konti</subfield>
58
    <subfield code="h">83.5</subfield>
59
  </datafield>
60
</record>
61
);
62
63
my $record=marcxml2marc($marcxml);
64
65
my ( $biblionumberTagid, $biblionumberSubfieldid ) =
66
            GetMarcFromKohaField( "biblio.biblionumber", $bibFramework );
67
my ( $biblioitemnumberTagid, $biblioitemnumberSubfieldid ) =
68
            GetMarcFromKohaField( "biblioitems.biblioitemnumber", $bibFramework );
69
70
# Making sure the Koha to MARC mappings stand correct
71
is ($biblionumberTagid, $biblioitemnumberTagid, 'Testing "Koha to MARC mapping" biblionumber and biblioitemnumber source MARC field sameness');
72
if ($biblionumberTagid ne $biblioitemnumberTagid) {
73
	warn "Koha to MARC mapping values biblio.biblionumber and biblioitems.biblioitemnumber must share the same MARC field!";
74
}
75
76
#Moving the 001 to the field configured for legacy id
77
my $legacyIdField = $record->field( '001' );
78
my $legacyId = $legacyIdField->data();
79
my $biblionumberField = MARC::Field->new( $biblionumberTagid, '', '',
80
   $biblionumberSubfieldid => $legacyId,
81
   $biblioitemnumberSubfieldid => $legacyId,
82
);
83
$record->append_fields($biblionumberField);
84
85
#Convenience method to easily change the legacy id.
86
# Is used to test out database id boundary values.
87
sub changeLegacyId {
88
    my ($record, $newId) = @_;
89
    
90
    # Because the author of Marc::Record decided it would be nice to replace all subfields with new ones whenever they are updated,
91
    #  old references are lost and need to be found again. 
92
    my $legacyIdField = $record->field( '001' );
93
    my $biblionumberField = $record->field( $biblionumberTagid );
94
    
95
    $legacyIdField->update( $newId );
96
    $biblionumberField->update( $biblionumberSubfieldid => $newId,
97
                                $biblioitemnumberSubfieldid => $newId);
98
    $legacyId = $newId;
99
100
    
101
}
102
103
##############################
104
### Running the main test! ###
105
##############################
106
107
## INSERT the record to the DB, SELECT the one we got,
108
## then find out if the biblionumber and biblioitemnumbers are the original ones.
109
110
my $dbh = C4::Context->dbh;
111
112
$dbh->{AutoCommit} = 0; #We don't want to save anything in DB as this is just a test run!
113
$dbh->{RaiseError} = 1;
114
115
##Testing just below the critical threshold in _koha_add_item() primary key validators.
116
##  Test should run OK. Also this biblionumber hardly is reserved :)
117
changeLegacyId($record, 2147483639);
118
119
my ( $newBiblionumber, $newBiblioitemnumber ) = AddBiblio( $record, $bibFramework, { defer_marc_save => 1 } );
120
my $selectedBiblio = GetBiblio($legacyId);
121
122
is ($legacyId, $newBiblionumber, 'Biblionumber returned by AddBiblio matches');
123
is ($legacyId, $selectedBiblio->{biblionumber}, 'Biblionumber returned by GetBiblio matches the legacy biblionumber');
124
125
126
##Testing primary key exhaustion situation. Validator should prevent biblionumber or biblioitemnumber INSERTion
127
##  if the value is over the safety threshold 2147483639 == LONG_MAX
128
##  So both tests should fail.
129
changeLegacyId($record, 2147483645);
130
131
( $newBiblionumber, $newBiblioitemnumber ) = AddBiblio( $record, $bibFramework, { defer_marc_save => 1 } );
132
$selectedBiblio = GetBiblio($legacyId);
133
134
isnt ($legacyId, $newBiblionumber, 'Testing primary key exhaustion prevention.');
135
isnt ($legacyId, $selectedBiblio->{biblionumber}, 'Primary key exhausted biblio matching');
136
137
##Testing bad primary key situation. Validator should prevent biblionumber or biblioitemnumber INSERTion
138
##  if the value is not a pure integer/long.
139
##  So both tests should fail.
140
changeLegacyId($record, '12134FAN');
141
142
( $newBiblionumber, $newBiblioitemnumber ) = AddBiblio( $record, $bibFramework, { defer_marc_save => 1 } );
143
$selectedBiblio = GetBiblio($legacyId);
144
145
isnt ($legacyId, $newBiblionumber, 'Testing primary key not-an-integer prevention.');
146
isnt ($legacyId, $selectedBiblio->{biblionumber}, 'Primary key not-an-integer biblio matching');
147
148
149
$dbh->rollback();
150
$dbh->disconnect();

Return to bug 6113