1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
#!/usr/local/bin/perl -w
# Copyright 1999-2019, Paul Johnson (paul@pjcj.net)
# This software is free. It is licensed under the same terms as Perl itself.
# The latest version of this software should be available from my homepage:
# http://www.pjcj.net
# Version 1.22 - 15th November 2019
use strict;
require 5.005;
package Lines;
use File::Basename;
use Test;
use vars qw($VERSION);
$VERSION = "1.22";
use Gedcom 1.22;
sub test {
my $class = shift;
my (%args) = @_;
die "tests not specified" unless defined $args{tests};
plan tests => $args{tests};
$args{gedcom_file} = (-d "t" ? "" : "../") ."royal.ged"
unless defined $args{gedcom_file};
die "report not specified" unless defined $args{report};
if (defined $args{report_command}) {
$args{lines} = "/home/pjcj/ged/other/lines/bin/lines302"
unless defined $args{lines};
if ( -x $args{lines} && open(L, "|$args{lines}")) {
my $db = basename($args{gedcom_file}, "\.ged");
system "rm -rf $db";
print L "$db\n";
print L "yur$args{gedcom_file}\n ";
print L "r$args{report}\n";
print L "$args{report_command}";
print L "q";
close(L) or die "Can't close <$args{lines}>";
print "\n";
}
}
ok 1;
$args{perl_program} = "$args{report}.plx"
unless defined $args{perl_program};
if ($args{generate}) {
system((-d "t" ? "" : "../") .
"lines2perl -quiet $args{report} > $args{perl_program}");
ok $? == 0;
} else {
ok 1;
}
$args{lines_report} = "$args{report}.l" unless defined $args{lines_report};
$args{perl_report} = "$args{report}.p" unless defined $args{perl_report};
die "perl_command not specified" unless defined $args{perl_command};
my $command = "|$^X " . (-d "t" ? "" : "-I .. ") .
"$args{perl_program} -quiet -gedcom_file $args{gedcom_file} ".
"> $args{perl_report}";
open P, $command or die "Can't run <$command>";
select P;
$| = 1;
print P $args{perl_command};
close(P) or die "Can't close <$args{perl_program}>";
ok 1;
# check the gedcom file is correct
ok open LO, $args{lines_report};
ok open PO, $args{perl_report};
ok <PO>, $_ while <LO>;
ok eof PO;
ok close PO;
ok close LO;
# ok unlink $args{perl_report};
}
sub import {
my $class = shift;
$class->test(@_) if @_;
}
1;
|
