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

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

attempting 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.6 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;
32use 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 foreach $p ($cgi->param())
44 {
45 $args{$p} = $cgi->param($p);
46 }
47
48 return \%args;
49}
50
51
52sub get_unique_dirname
53{
54 my ($args) = @_;
55
56 my $dirname = "";
57
58 my $fullname = $args->{'bc1fullname'};
59 my $in_gsdl_area = $args->{'bc1ingsdlarea'};
60 my $copy_dir = $args->{'bc1copydir'};
61
62 # if inputdir is in gsdl area then need to extract existing dirname
63 if (($in_gsdl_area eq "yes") && (($copy_dir eq "no")))
64 {
65 my $inputdir = $args->{'bc1inputdir'};
66 my $dirsep_re = &util::get_re_dirsep();
67 my @id_split = split(/$dirsep_re/,$inputdir);
68 while (@id_split>0)
69 {
70 $dirname = pop(@id_split);
71 last if ($dirname =~ m/(import|building)/i);
72 }
73 $dirname = pop(@id_split);
74
75 # check to see if config file already exists
76 my $cfg_filename
77 = &util::filename_cat($ENV{'GSDLHOME'},"collect",$dirname,
78 "etc","collect.cfg");
79 if (-e $cfg_filename)
80 {
81 &webpageutil::error_location($args,"_messconfigexists_");
82 return "";
83 }
84 }
85 else
86 {
87 # clean up input for heuristic that derives directory name for a new collection
88 $fullname =~ s/\s+/ /g;
89 $fullname =~ tr/[A-Z]/[a-z]/;
90 my @fn_split = split(" ",$fullname);
91 map { $_ =~ s/\W//g } @fn_split; # remove any non-word characters
92
93 my $no_words = scalar(@fn_split);
94 if ($no_words == 0)
95 {
96 &webpageutil::error_location($args,"_messnofn_");
97 return "";
98 }
99
100 my $use_words = ($no_words<=6) ? $no_words : 6;
101 my $substr_len = int(6/$use_words);
102
103 my $i;
104 for ($i=0; $i<$use_words; $i++)
105 {
106 $dirname .= substr($fn_split[$i],0,$substr_len);
107 }
108
109 # check to see if dirname is unique
110 my $fulldirname
111 = &util::filename_cat($ENV{'GSDLHOME'},"collect",$dirname);
112 if (-e $fulldirname)
113 {
114 my $version = 0;
115 do
116 {
117 $version++;
118 $fulldirname
119 = &util::filename_cat($ENV{'GSDLHOME'},"collect",
120 "${dirname}v$version");
121
122 } while (-e $fulldirname);
123
124 $dirname = "${dirname}v$version";
125 }
126 }
127
128 return $dirname;
129}
130
131
132sub main
133{
134 # get arguments
135 my $args = parse_cgiargs();
136
137 # get unique dirname
138 my $unique_dirname = get_unique_dirname($args);
139 if ($unique_dirname ne "")
140 {
141 my $fullname = $args->{'bc1fullname'};
142 my $contact_email = $args->{'bc1contactemail'};
143 my $about_desc = $args->{'bc1aboutdesc'};
144 my $src_format = $args->{'bc1srcformat'};
145 my $file_or_url = $args->{'bc1fileorurl'};
146 my $input_dir = $args->{'bc1inputdir'};
147 my $copy_dir = $args->{'bc1copydir'};
148 my $in_gsdl_area = $args->{'bc1ingsdlarea'};
149 my $acronyms = $args->{'bc1acronyms'};
150
151 my $cmd = "perl ";
152 $cmd .= &util::filename_cat($ENV{'GSDLHOME'}, "bin", "script", "mkcol.pl");
153 $cmd .= " -title \"$fullname\"";
154 $cmd .= " -creator $contact_email";
155 $cmd .= " -about \"$about_desc\"";
156 $cmd .= " -plugin \"GMLPlug\"";
157 $cmd .= " -plugin \"${src_format}Plug\"";
158 $cmd .= " -plugin \"ArcPlug\"";
159 $cmd .= " -plugin \"RecPlug\"";
160### $cmd .= " -refine \"$refine_plugs\"";
161 $cmd .= " $unique_dirname";
162 my $status = system($cmd);
163 $status /= 256;
164
165 if ($status == 0)
166 {
167 # append copydir, file_or_url and input_dir to end of collect.cfg
168 # we'll also append DocumentUseHTML if processing HTML docs
169 my $cfg_filename
170 = &util::filename_cat($ENV{'GSDLHOME'},"collect",$unique_dirname,
171 "etc","collect.cfg");
172 if (open(CFGAPP,">>$cfg_filename"))
173 {
174 if (flock(CFGAPP,LOCK_EX))
175 {
176 print CFGAPP "\n";
177
178 if ($src_format eq "HTML") {
179 print CFGAPP "format\tDocumentUseHTML\ttrue\n\n";
180 }
181
182 print CFGAPP "building\tfileorurl\t$file_or_url\n";
183 print CFGAPP "building\tinputdir\t$input_dir\n";
184 print CFGAPP "building\tcopydir\t\t$copy_dir\n";
185 print CFGAPP "building\tingsdlarea\t$in_gsdl_area\n";
186 flock(CFGAPP,LOCK_UN);
187 close(CFGAPP);
188 }
189 else
190 {
191 # problem locking file
192 my $mess = "Unable to lock collection";
193 $mess .= " configuration file: $cfg_filename";
194 &webpageutil::error_location($args,$mess);
195 close(CFGAPP);
196 return;
197 }
198 }
199 else
200 {
201 # problem
202 my $mess = "Unable to append to collection";
203 $mess .= " configuration file: $cfg_filename";
204 &webpageutil::error_location($args,$mess);
205 return;
206 }
207
208
209 # append dirname to end of collection config file
210 my $collist_filename
211 = &util::filename_cat($ENV{'GSDLHOME'},"etc","collections.txt");
212 if (open(CLAPP,">>$collist_filename"))
213 {
214 if (flock(CLAPP,LOCK_EX))
215 {
216 print CLAPP "$unique_dirname\n";
217 flock(CLAPP,LOCK_UN);
218 close(CLAPP);
219 }
220 else
221 {
222 # problem locking file
223 my $mess = "Unable to lock collection list";
224 $mess .= " configuration file: $collist_filename";
225 &webpageutil::error_location($args,$mess);
226 close(CLAPP);
227 return;
228 }
229 }
230 else
231 {
232 # problem
233 my $mess = "Unable to append to collection list";
234 $mess .= " configuration file: $collist_filename";
235 &webpageutil::error_location($args,$mess);
236 return;
237 }
238
239 }
240 else
241 {
242 my $mess = "An error was encountered: error status = $status";
243 &webpageutil::error_location($args,$mess);
244 return;
245 }
246 }
247 else
248 {
249 my $mess = "No unique directory name specified for collection";
250 &webpageutil::error_location($args,$mess);
251 return;
252 }
253
254 my $mess_url = "$args->{'httpbuild'}&bca=mess&bc1dirname=$unique_dirname";
255 print "Location: $mess_url&head=_headdone_&mess=_messdonenewcol_\n\n";
256
257}
258
259&main();
Note: See TracBrowser for help on using the repository browser.