source: trunk/gsdl/cgi-bin/webpage_mkcol.pl@ 1171

Last change on this file since 1171 was 1171, checked in by sjboddie, 24 years ago

more changes to try to get end-user collection building working
under windows

  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 6.8 KB
Line 
1#!perl -w
2
3###########################################################################
4#
5# webpage_mkcol.pl --
6# A component of the Greenstone digital library software
7# from the New Zealand Digital Library Project at the
8# University of Waikato, New Zealand.
9#
10# Copyright (C) 1999 New Zealand Digital Library Project
11#
12# This program is free software; you can redistribute it and/or modify
13# it under the terms of the GNU General Public License as published by
14# the Free Software Foundation; either version 2 of the License, or
15# (at your option) any later version.
16#
17# This program is distributed in the hope that it will be useful,
18# but WITHOUT ANY WARRANTY; without even the implied warranty of
19# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20# GNU General Public License for more details.
21#
22# You should have received a copy of the GNU General Public License
23# along with this program; if not, write to the Free Software
24# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25#
26###########################################################################
27
28# This program is a webpage wrapper to the mkcol.pl process
29
30use CGI;
31use GSDLHOME;
32#use Fcntl ':flock';
33
34require util;
35require webpageutil;
36
37sub parse_cgiargs
38{
39 # get arguments
40 my $cgi = new CGI;
41 my %args = ();
42
43 open (FILE, '>d:\gsdl\logout.txt') || die;
44
45 foreach $p ($cgi->param())
46 {
47 $args{$p} = $cgi->param($p);
48
49 print FILE "webpage_mkcol.pl - $p -> $args{$p}\n";
50 }
51
52 close FILE;
53 return \%args;
54}
55
56
57sub get_unique_dirname
58{
59 my ($args) = @_;
60
61 my $dirname = "";
62
63 my $fullname = $args->{'bc1fullname'};
64 my $in_gsdl_area = $args->{'bc1ingsdlarea'};
65 my $copy_dir = $args->{'bc1copydir'};
66
67 # if inputdir is in gsdl area then need to extract existing dirname
68 if (($in_gsdl_area eq "yes") && (($copy_dir eq "no")))
69 {
70 my $inputdir = $args->{'bc1inputdir'};
71 my $dirsep_re = &util::get_re_dirsep();
72 my @id_split = split(/$dirsep_re/,$inputdir);
73 while (@id_split>0)
74 {
75 $dirname = pop(@id_split);
76 last if ($dirname =~ m/(import|building)/i);
77 }
78 $dirname = pop(@id_split);
79
80 # check to see if config file already exists
81 my $cfg_filename
82 = &util::filename_cat($ENV{'GSDLHOME'},"collect",$dirname,
83 "etc","collect.cfg");
84 if (-e $cfg_filename)
85 {
86 &webpageutil::error_location($args,"_messconfigexists_");
87 return "";
88 }
89 }
90 else
91 {
92 # clean up input for heuristic that derives directory name for a
93 # new collection
94 $fullname =~ s/\s+/ /g;
95 $fullname =~ tr/[A-Z]/[a-z]/;
96 my @fn_split = split(" ",$fullname);
97 map { $_ =~ s/\W//g } @fn_split; # remove any non-word characters
98
99 my $no_words = scalar(@fn_split);
100 if ($no_words == 0)
101 {
102 &webpageutil::error_location($args,"_messnofn_");
103 return "";
104 }
105
106 my $use_words = ($no_words<=6) ? $no_words : 6;
107 my $substr_len = int(6/$use_words);
108
109 my $i;
110 for ($i=0; $i<$use_words; $i++)
111 {
112 $dirname .= substr($fn_split[$i],0,$substr_len);
113 }
114
115 # check to see if dirname is unique
116 my $fulldirname
117 = &util::filename_cat($ENV{'GSDLHOME'},"collect",$dirname);
118 if (-e $fulldirname)
119 {
120 my $version = 0;
121 do
122 {
123 $version++;
124 $fulldirname
125 = &util::filename_cat($ENV{'GSDLHOME'},"collect",
126 "${dirname}v$version");
127
128 } while (-e $fulldirname);
129
130 $dirname = "${dirname}v$version";
131 }
132 }
133
134 return $dirname;
135}
136
137
138sub main
139{
140 # get arguments
141 my $args = parse_cgiargs();
142
143 # get unique dirname
144 my $unique_dirname = get_unique_dirname($args);
145 if ($unique_dirname ne "")
146 {
147 my $fullname = $args->{'bc1fullname'};
148 my $contact_email = $args->{'bc1contactemail'};
149 my $about_desc = $args->{'bc1aboutdesc'};
150 my $src_format = $args->{'bc1srcformat'};
151 my $file_or_url = $args->{'bc1fileorurl'};
152 my $input_dir = $args->{'bc1inputdir'};
153 my $copy_dir = $args->{'bc1copydir'};
154 my $in_gsdl_area = $args->{'bc1ingsdlarea'};
155 my $acronyms = $args->{'bc1acronyms'};
156
157 my $cmd = "perl ";
158 $cmd .= &util::filename_cat($ENV{'GSDLHOME'}, "bin", "script", "mkcol.pl");
159 $cmd .= " -title \"$fullname\"";
160 $cmd .= " -creator $contact_email";
161 $cmd .= " -about \"$about_desc\"";
162 $cmd .= " -plugin \"GMLPlug\"";
163 $cmd .= " -plugin \"${src_format}Plug\"";
164 $cmd .= " -plugin \"ArcPlug\"";
165 $cmd .= " -plugin \"RecPlug\"";
166### $cmd .= " -refine \"$refine_plugs\"";
167 $cmd .= " $unique_dirname";
168
169 my $status = system($cmd);
170 $status /= 256;
171
172 if ($status == 0)
173 {
174 # append copydir, file_or_url and input_dir to end of collect.cfg
175 # we'll also append DocumentUseHTML if processing HTML docs
176 my $cfg_filename
177 = &util::filename_cat($ENV{'GSDLHOME'},"collect",$unique_dirname,
178 "etc","collect.cfg");
179 if (open(CFGAPP,">>$cfg_filename"))
180 {
181# if (flock(CFGAPP,LOCK_EX))
182# {
183 print CFGAPP "\n";
184
185 if ($src_format eq "HTML") {
186 print CFGAPP "format\tDocumentUseHTML\ttrue\n\n";
187 }
188
189 print CFGAPP "building\tfileorurl\t$file_or_url\n";
190 print CFGAPP "building\tinputdir\t$input_dir\n";
191 print CFGAPP "building\tcopydir\t\t$copy_dir\n";
192 print CFGAPP "building\tingsdlarea\t$in_gsdl_area\n";
193# flock(CFGAPP,LOCK_UN);
194 close(CFGAPP);
195# }
196# else
197# {
198 # problem locking file
199# my $mess = "Unable to lock collection";
200# $mess .= " configuration file: $cfg_filename";
201# &webpageutil::error_location($args,$mess);
202# close(CFGAPP);
203# return;
204# }
205 }
206 else
207 {
208 # problem
209 my $mess = "Unable to append to collection";
210 $mess .= " configuration file: $cfg_filename";
211 &webpageutil::error_location($args,$mess);
212 return;
213 }
214
215
216 # append dirname to end of collection config file
217 my $collist_filename
218 = &util::filename_cat($ENV{'GSDLHOME'},"etc","collections.txt");
219 if (open(CLAPP,">>$collist_filename"))
220 {
221# if (flock(CLAPP,LOCK_EX))
222# {
223 print CLAPP "$unique_dirname\n";
224# flock(CLAPP,LOCK_UN);
225 close(CLAPP);
226# }
227# else
228# {
229 # problem locking file
230# my $mess = "Unable to lock collection list";
231# $mess .= " configuration file: $collist_filename";
232# &webpageutil::error_location($args,$mess);
233# close(CLAPP);
234# return;
235# }
236 }
237 else
238 {
239 # problem
240 my $mess = "Unable to append to collection list";
241 $mess .= " configuration file: $collist_filename";
242 &webpageutil::error_location($args,$mess);
243 return;
244 }
245
246 }
247 else
248 {
249 my $mess = "An error was encountered: error status = $status";
250 &webpageutil::error_location($args,$mess);
251 return;
252 }
253 }
254 else
255 {
256 my $mess = "No unique directory name specified for collection";
257 &webpageutil::error_location($args,$mess);
258 return;
259 }
260
261 my $mess_url = "$args->{'httpbuild'}&bca=mess&bc1dirname=$unique_dirname";
262 print "Location: $mess_url&head=_headdone_&mess=_messdonenewcol_\n\n";
263
264}
265
266&main();
Note: See TracBrowser for help on using the repository browser.