MOOCOW / DDC-Concordance-0.50 / ddc-cgi.perl 

            

              
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147

              
#!/usr/bin/perl -w
use lib qw(. ./ddc-perl ./DDC-perl);
use DDC::Concordance;
use JSON;
use Encode qw(encode decode);
use Getopt::Long qw(:config no_ignore_case);
use File::Basename qw(basename dirname);
use CGI qw(:standard :cgi-lib);
use strict;
##======================================================================
## Constants & Globals
our $prog = basename($0);
our $progdir = dirname($0);
(our $rcfile = "$progdir/$prog") =~ s/\.perl$/.rc/i;
## $cfg: site configuration & defaults (loaded from $rcfile if available)
our $cfg =
  {
   ##-- user options
   server   => 'localhost:50250', ##-- ddc server
   mode     => 'json',            ##-- ddc query mode (json,html,table,text)
   corpus   => '',
   start    => 1,
   limit    => 10,
   ##-- client options
   timeout  => 60,
   encoding=>'utf8',
   parseMeta=>1,
   parseContext=>1,
   keepRaw=>0,
   fieldNames=>undef,
   fieldSeparator=>"\x{1f}",
   tokenSeparator=>"\x{1e}",
   dropFields => [],
   expandFields => 1,
  };
## @defaults: user-level keys in $cfg with a default value
our @defaults = qw(server corpus mode start limit);
##======================================================================
## Subs: Configuration
## \%cfg = loadConfig($jsonFile)
## \%cfg = loadConfig($jsonFile,\%cfg)
sub loadConfig {
  my ($rcfile,$cfg)=@_;
  open(RC,"<$rcfile") or die("$prog: open failed for config file '$rcfile': $!");
  local $/=undef;
  my $rcstr = <RC>;
  close(RC) or die("$prog: close failed for config file '$rcfile': $!");
  ##-- remove comments
  $rcstr =~ s/^\#.*$//mg;
  ##-- decode
  my $rcdata = decode_json($rcstr)
    or die("$prog: could not decode config data from '$rcfile': $!");
  ##-- merge (clobber)
  %$cfg = (%$cfg,%$rcdata);
  return $cfg;
}
##======================================================================
## MAIN
##-- site configuration
$cfg = loadConfig($rcfile,$cfg) if (-r $rcfile);
##-- CGI init
charset($cfg->{encoding}); ##-- initialize CGI charset
my $vars = {};
if (param()) {
  $vars = Vars();
}
my ($dclient,$content);
eval {
  ##-- get query
  my $query = $vars->{'q'};
  die("$prog: no 'q' (query) parameter specified!") if (($query//'') eq '');
  $query  = decode($cfg->{encoding},$query) if (defined($cfg->{qencoding}));
  ##-- defaults
  $vars->{$_} = $cfg->{$_} foreach (grep {!exists($vars->{$_})} @defaults);
  ##-- create client
  my $server = $vars->{server}
    or die("$prog: no 'server' (ddc server) parameter defined!");
  $dclient = DDC::Client::Distributed->new(%$cfg,
                                           connect=>{PeerAddr=>$server},
                                           mode=>$vars->{mode},
                                           start=>($vars->{start} > 0 ? ($vars->{start}-1) : 0),
                                           limit=>$vars->{limit},
                                          )
    or die("$prog: could not create DDC::Client::Distributed: $!");
  $dclient->open()
    or die("$prog: could not connect to DDC server at $server: $!");
  ##-- append subcorpus clause to query if requested
  my @corpora = grep {defined($_) && $_ ne ''} split(/[\s\,\:\+]+/,$vars->{corpus});
  $query .= ' :'.join(',',@corpora) if (@corpora);
  ##-- send query
  $content = $dclient->queryRaw($query)
    or die("$prog: query ($query) failed: $!");
};
##-- check for errors
if ($@) {
  print
    (header(-status=>500),
     start_html('Error'),
     h1('Error'),"\n",
     pre(escapeHTML($@)),
     end_html);
  exit 1;
}
##-- dump content
my %mode_opts =
  (
   html => {type=>'text/html'},
   text => {type=>'text/plain',headers=>{'-Content-Disposition'=>"inline; filename=\"ddc.txt\""}},
   table  => {type=>'text/plain',headers=>{'-Content-Disposition'=>"inline; filename=\"ddc.tab\""}},
   json => {type=>'application/json',headers=>{'-Content-Disposition'=>"inline; filename=\"ddc.json\""}},
  );
my $modeh = $mode_opts{$dclient->{mode}};
if ($vars->{raw} || $vars->{debug} || $dclient->{mode} eq 'req') {
  delete $modeh->{headers}{'-Content-Disposition'};
  $modeh->{type} = 'text/plain';
}
print
  header($vars->{debug}
         ? (-type=>'text/plain')
         : (-type=>$modeh->{type},%{$modeh->{headers}||{}})),
  $content;