|
Lines 21-28
use Modern::Perl;
Link Here
|
| 21 |
use FindBin qw( $Bin ); |
21 |
use FindBin qw( $Bin ); |
| 22 |
|
22 |
|
| 23 |
use Test::NoWarnings; |
23 |
use Test::NoWarnings; |
| 24 |
use Test::More tests => 8; |
24 |
use Test::More tests => 9; |
| 25 |
use Test::MockModule; |
25 |
use Test::MockModule; |
|
|
26 |
use JSON qw( decode_json ); |
| 26 |
|
27 |
|
| 27 |
use t::lib::Mocks; |
28 |
use t::lib::Mocks; |
| 28 |
use t::lib::Mocks::Logger; |
29 |
use t::lib::Mocks::Logger; |
|
Lines 1907-1909
subtest 'LSL and LSQ field copy to item_hash' => sub {
Link Here
|
| 1907 |
|
1908 |
|
| 1908 |
$schema->storage->txn_rollback; |
1909 |
$schema->storage->txn_rollback; |
| 1909 |
}; |
1910 |
}; |
|
|
1911 |
|
| 1912 |
subtest 'servicing_instructions_quote_processing' => sub { |
| 1913 |
plan tests => 29; |
| 1914 |
|
| 1915 |
$schema->storage->txn_begin; |
| 1916 |
|
| 1917 |
# Setup test data |
| 1918 |
my $test_san = '5013546098818'; |
| 1919 |
my $dirname = ( $Bin =~ /^(.*\/t\/)/ ? $1 . 'edi_testfiles/' : q{} ); |
| 1920 |
|
| 1921 |
my $active_period = $builder->build( |
| 1922 |
{ |
| 1923 |
source => 'Aqbudgetperiod', |
| 1924 |
value => { budget_period_active => 1 } |
| 1925 |
} |
| 1926 |
); |
| 1927 |
|
| 1928 |
# Create file transport |
| 1929 |
my $file_transport = $builder->build( |
| 1930 |
{ |
| 1931 |
source => 'FileTransport', |
| 1932 |
value => { |
| 1933 |
name => 'Test Servicing Transport', |
| 1934 |
transport => 'local', |
| 1935 |
download_directory => $dirname, |
| 1936 |
upload_directory => $dirname, |
| 1937 |
} |
| 1938 |
} |
| 1939 |
); |
| 1940 |
|
| 1941 |
# Create vendor EDI account |
| 1942 |
my $account = $builder->build( |
| 1943 |
{ |
| 1944 |
source => 'VendorEdiAccount', |
| 1945 |
value => { |
| 1946 |
description => 'servicing instruction vendor', |
| 1947 |
file_transport_id => $file_transport->{file_transport_id}, |
| 1948 |
plugin => '', |
| 1949 |
san => $test_san, |
| 1950 |
orders_enabled => 1, |
| 1951 |
auto_orders => 0, |
| 1952 |
} |
| 1953 |
} |
| 1954 |
); |
| 1955 |
|
| 1956 |
my $ean = $builder->build( |
| 1957 |
{ |
| 1958 |
source => 'EdifactEan', |
| 1959 |
value => { |
| 1960 |
description => 'test ean', |
| 1961 |
branchcode => undef, |
| 1962 |
ean => $test_san |
| 1963 |
} |
| 1964 |
} |
| 1965 |
); |
| 1966 |
|
| 1967 |
# Setup branches used in test file |
| 1968 |
for my $code (qw(CPL MPL FPL)) { |
| 1969 |
local $SIG{__WARN__} = sub { }; # Suppress warnings |
| 1970 |
eval { |
| 1971 |
$builder->build( |
| 1972 |
{ |
| 1973 |
source => 'Branch', |
| 1974 |
value => { branchcode => $code } |
| 1975 |
} |
| 1976 |
); |
| 1977 |
}; # Ignore duplicate key errors |
| 1978 |
} |
| 1979 |
|
| 1980 |
# Setup funds used in test file |
| 1981 |
for my $code (qw(REF LOAN)) { |
| 1982 |
$builder->build( |
| 1983 |
{ |
| 1984 |
source => 'Aqbudget', |
| 1985 |
value => { |
| 1986 |
budget_code => $code, |
| 1987 |
budget_period_id => $active_period->{budget_period_id} |
| 1988 |
} |
| 1989 |
} |
| 1990 |
); |
| 1991 |
} |
| 1992 |
|
| 1993 |
# Add EDIFACT_SI authorized values for servicing instruction codes |
| 1994 |
for my $code ( [ 'BB', 'Barcode labelling' ], [ 'BI', 'Binding' ], [ 'BJ', 'Sleeving' ] ) { |
| 1995 |
$builder->build( |
| 1996 |
{ |
| 1997 |
source => 'AuthorisedValue', |
| 1998 |
value => { |
| 1999 |
category => 'EDIFACT_SI', |
| 2000 |
authorised_value => $code->[0], |
| 2001 |
lib => $code->[1] |
| 2002 |
} |
| 2003 |
} |
| 2004 |
); |
| 2005 |
} |
| 2006 |
|
| 2007 |
my $filename = 'QUOTES_SERVICING.CEQ'; |
| 2008 |
ok( -e $dirname . $filename, 'File QUOTES_SERVICING.CEQ found' ); |
| 2009 |
|
| 2010 |
my $trans = Koha::Edifact::Transport->new( $account->{id} ); |
| 2011 |
$trans->working_directory($dirname); |
| 2012 |
|
| 2013 |
my $mhash = $trans->message_hash(); |
| 2014 |
$mhash->{message_type} = 'QUOTE'; |
| 2015 |
$trans->ingest( $mhash, $filename ); |
| 2016 |
|
| 2017 |
my $quote = $schema->resultset('EdifactMessage')->find( { filename => $filename } ); |
| 2018 |
ok( $quote, 'Quote message created' ); |
| 2019 |
|
| 2020 |
t::lib::Mocks::mock_preference( 'AcqCreateItem', 'ordering' ); |
| 2021 |
|
| 2022 |
# Process quote |
| 2023 |
my $die; |
| 2024 |
eval { |
| 2025 |
process_quote($quote); |
| 2026 |
1; |
| 2027 |
} or do { |
| 2028 |
$die = $@; |
| 2029 |
}; |
| 2030 |
ok( !$die, 'Quote with servicing instructions processed without dying' ); |
| 2031 |
|
| 2032 |
# Get the basket |
| 2033 |
my $baskets = Koha::Acquisition::Baskets->search( { booksellerid => $account->{vendor_id} } ); |
| 2034 |
is( $baskets->count, 1, 'One basket created' ); |
| 2035 |
|
| 2036 |
my $basket = $baskets->next; |
| 2037 |
my $orders = $basket->orders->search( {}, { order_by => 'ordernumber' } ); |
| 2038 |
is( $orders->count, 4, 'Four order lines created (1 + 2 + 1)' ); |
| 2039 |
|
| 2040 |
# Test Case 1: First order - both LVC (BB) and LVT in same group |
| 2041 |
my $order1 = $orders->next; |
| 2042 |
ok( $order1->servicing_instruction, 'First order has servicing_instruction' ); |
| 2043 |
|
| 2044 |
my $si1 = decode_json( $order1->servicing_instruction ); |
| 2045 |
is( ref($si1), 'ARRAY', 'servicing_instruction is an array' ); |
| 2046 |
is( scalar @$si1, 1, 'First order has 1 servicing instruction group' ); |
| 2047 |
|
| 2048 |
my $group1 = $si1->[0]; |
| 2049 |
is( ref($group1), 'ARRAY', 'First group is an array' ); |
| 2050 |
is( scalar @$group1, 2, 'First group has 2 instructions (LVC + LVT)' ); |
| 2051 |
|
| 2052 |
# Find LVC and LVT entries |
| 2053 |
my ($lvc1) = grep { $_->{type} eq 'LVC' } @$group1; |
| 2054 |
my ($lvt1) = grep { $_->{type} eq 'LVT' } @$group1; |
| 2055 |
|
| 2056 |
ok( $lvc1, 'First order has LVC instruction' ); |
| 2057 |
is( $lvc1->{value}, 'BB', 'LVC value is BB (Barcode labelling)' ); |
| 2058 |
|
| 2059 |
ok( $lvt1, 'First order has LVT instruction' ); |
| 2060 |
is( $lvt1->{value}, 'Spine label required', 'LVT value is correct freetext' ); |
| 2061 |
|
| 2062 |
# Test Case 2: Second order - only LVC (BI) |
| 2063 |
my $order2 = $orders->next; |
| 2064 |
ok( $order2->servicing_instruction, 'Second order has servicing_instruction' ); |
| 2065 |
|
| 2066 |
my $si2 = decode_json( $order2->servicing_instruction ); |
| 2067 |
is( scalar @$si2, 1, 'Second order has 1 servicing instruction group' ); |
| 2068 |
|
| 2069 |
my $group2 = $si2->[0]; |
| 2070 |
is( scalar @$group2, 1, 'Second group has 1 instruction (LVC only)' ); |
| 2071 |
|
| 2072 |
is( $group2->[0]->{type}, 'LVC', 'Second order has LVC type' ); |
| 2073 |
is( $group2->[0]->{value}, 'BI', 'LVC value is BI (Binding)' ); |
| 2074 |
|
| 2075 |
# Test Case 3: Third order - LVC (BJ) and LVT in same group |
| 2076 |
my $order3 = $orders->next; |
| 2077 |
ok( $order3->servicing_instruction, 'Third order has servicing_instruction' ); |
| 2078 |
|
| 2079 |
my $si3 = decode_json( $order3->servicing_instruction ); |
| 2080 |
is( scalar @$si3, 1, 'Third order has 1 servicing instruction group' ); |
| 2081 |
|
| 2082 |
my $group3 = $si3->[0]; |
| 2083 |
is( scalar @$group3, 2, 'Third group has 2 instructions (LVC + LVT)' ); |
| 2084 |
|
| 2085 |
my ($lvc3) = grep { $_->{type} eq 'LVC' } @$group3; |
| 2086 |
my ($lvt3) = grep { $_->{type} eq 'LVT' } @$group3; |
| 2087 |
|
| 2088 |
is( $lvc3->{value}, 'BJ', 'Third order LVC is BJ (Sleeving)' ); |
| 2089 |
is( $lvt3->{value}, 'Handle with care', 'Third order LVT has correct text' ); |
| 2090 |
|
| 2091 |
# Test Case 4: Fourth order - only LVT |
| 2092 |
my $order4 = $orders->next; |
| 2093 |
ok( $order4->servicing_instruction, 'Fourth order has servicing_instruction' ); |
| 2094 |
|
| 2095 |
my $si4 = decode_json( $order4->servicing_instruction ); |
| 2096 |
is( scalar @$si4, 1, 'Fourth order has 1 servicing instruction group' ); |
| 2097 |
|
| 2098 |
my $group4 = $si4->[0]; |
| 2099 |
is( scalar @$group4, 1, 'Fourth group has 1 instruction (LVT only)' ); |
| 2100 |
|
| 2101 |
is( $group4->[0]->{type}, 'LVT', 'Fourth order has LVT type' ); |
| 2102 |
is( $group4->[0]->{value}, 'Rush processing required', 'Fourth order LVT has correct text' ); |
| 2103 |
|
| 2104 |
$schema->storage->txn_rollback; |
| 2105 |
}; |