root/branches/New_Config_Format-branch/gsdl/cgi-bin/webpage_mkcol.pl @ 1279

Revision 1279, 6.0 KB (checked in by sjboddie, 20 years ago)

merged changes to trunk into New_Config_Format branch

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