root/trunk/gsdl/cgi-bin/webpage_mkcol.pl @ 724

Revision 724, 6.3 KB (checked in by davidb, 20 years ago)

Perl CGI scripts to help in webpage based collection building.

  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
Line 
1#!/usr/local/bin/perl5 -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 = "mkcol.pl";
152    $cmd .= " -title   \"$fullname\"";
153    $cmd .= " -creator $contact_email";
154    $cmd .= " -about   \"$about_desc\"";
155    $cmd .= " -plugins \"GMLPlug ${src_format}Plug ArcPlug RecPlug\"";
156### $cmd .= " -refine  \"$refine_plugs\"";
157    $cmd .= " $unique_dirname";
158    my $status = system($cmd);
159    $status /= 256;
160
161    if ($status == 0)
162    {
163        # append copydir, file_or_url and input_dir to end of collect.cfg
164        my $cfg_filename
165        = &util::filename_cat($ENV{'GSDLHOME'},"collect",$unique_dirname,
166                      "etc","collect.cfg");
167        if (open(CFGAPP,">>$cfg_filename"))
168        {
169        if (flock(CFGAPP,LOCK_EX))
170        {
171            print CFGAPP "\n";
172            print CFGAPP "building\tfileorurl\t$file_or_url\n";
173            print CFGAPP "building\tinputdir\t$input_dir\n";
174            print CFGAPP "building\tcopydir\t\t$copy_dir\n";
175            print CFGAPP "building\tingsdlarea\t$in_gsdl_area\n";
176            flock(CFGAPP,LOCK_UN);
177            close(CFGAPP);
178        }
179        else
180        {
181            # problem locking file
182            my $mess = "Unable to lock collection";
183            $mess .= " configuration file: $cfg_filename";
184            &webpageutil::error_location($args,$mess);
185            close(CFGAPP);
186            return;
187        }
188        }
189        else
190        {
191        # problem
192        my $mess = "Unable to append to collection";
193        $mess .= " configuration file: $cfg_filename";
194        &webpageutil::error_location($args,$mess);
195        return;
196        }
197
198
199        # append dirname to end of collection config file
200        my $collist_filename
201        = &util::filename_cat($ENV{'GSDLHOME'},"etc","collections.txt");
202        if (open(CLAPP,">>$collist_filename"))
203        {
204        if (flock(CLAPP,LOCK_EX))
205        {
206            print CLAPP "$unique_dirname\n";
207            flock(CLAPP,LOCK_UN);
208            close(CLAPP);
209        }
210        else
211        {
212            # problem locking file
213            my $mess = "Unable to lock collection list";
214            $mess .= " configuration file: $collist_filename";
215            &webpageutil::error_location($args,$mess);
216            close(CLAPP);
217            return;
218        }
219        }
220        else
221        {
222        # problem
223        my $mess = "Unable to append to collection list";
224        $mess .= " configuration file: $collist_filename";
225        &webpageutil::error_location($args,$mess);
226        return;
227        }
228       
229    }
230    else
231    {
232        my $mess = "An error was encountered: error status = $status";
233        &webpageutil::error_location($args,$mess);
234        return;
235    }
236    }
237    else
238    {
239    my $mess = "No unique directory name specified for collection";
240    &webpageutil::error_location($args,$mess);
241    return;
242    }
243
244    my $mess_url = "$args->{'httpbuild'}&bca=mess&bc1dirname=$unique_dirname";
245    print "Location: $mess_url&head=_headdone_&mess=_messdonenewcol_\n\n";
246
247}
248
249&main();
250
251
252
253
254
Note: See TracBrowser for help on using the browser.