source: main/tags/2.21/gsdl/cgi-bin/webpage_mkcol.pl@ 32915

#!perl -w

###########################################################################
#
# webpage_mkcol.pl --
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 1999 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################

# This program is a webpage wrapper to the mkcol.pl process

use CGI;
use GSDLHOME;
use gflock;

require util;
require webpageutil;

sub parse_cgiargs
{
    # get arguments
    my $cgi = new CGI;
    my %args = ();
    
    open (FILE, '>d:\gsdl\logout.txt') || die;

    foreach $p ($cgi->param()) 
    { 
    $args{$p} = $cgi->param($p);

    print FILE "webpage_mkcol.pl - $p -> $args{$p}\n";
    }

    close FILE;
    return \%args;
}


sub get_unique_dirname
{
    my ($args) = @_;

    my $dirname = "";

    my $fullname = $args->{'bc1fullname'};
    my $in_gsdl_area = $args->{'bc1ingsdlarea'};
    my $copy_dir = $args->{'bc1copydir'};

    # if inputdir is in gsdl area then need to extract existing dirname
    if (($in_gsdl_area eq "yes") && (($copy_dir eq "no")))
    {
    my $inputdir = $args->{'bc1inputdir'};
    my $dirsep_re = &util::get_re_dirsep();
    my @id_split = split(/$dirsep_re/,$inputdir);
    while (@id_split>0)
    {
        $dirname = pop(@id_split);
        last if ($dirname =~ m/(import|building)/i);
    }
    $dirname = pop(@id_split);

    # check to see if config file already exists
    my $cfg_filename
        = &util::filename_cat($ENV{'GSDLHOME'},"collect",$dirname,
                 "etc","collect.cfg");
    if (-e $cfg_filename)
    {
        &webpageutil::error_location($args,"_messconfigexists_");
        return "";
    }   
    }
    else
    {
    # clean up input for heuristic that derives directory name for a
    # new collection
    $fullname =~ s/\s+/ /g;
    $fullname =~ tr/[A-Z]/[a-z]/;
    my @fn_split = split(" ",$fullname);
    map { $_ =~ s/\W//g } @fn_split; # remove any non-word characters
    
    my $no_words = scalar(@fn_split);
    if ($no_words == 0)
    {
        &webpageutil::error_location($args,"_messnofn_");
        return "";
    }
    
    my $use_words = ($no_words<=6) ? $no_words : 6;
    my $substr_len = int(6/$use_words);
    
    my $i;
    for ($i=0; $i<$use_words; $i++)
    {
        $dirname .= substr($fn_split[$i],0,$substr_len);
    }
    
    # check to see if dirname is unique
    my $fulldirname 
        = &util::filename_cat($ENV{'GSDLHOME'},"collect",$dirname);
    if (-e $fulldirname)
    {
        my $version = 0;
        do
        {
        $version++;
        $fulldirname 
            = &util::filename_cat($ENV{'GSDLHOME'},"collect",
                      "${dirname}v$version");

        } while (-e $fulldirname);

        $dirname = "${dirname}v$version";
    }
    }

    return $dirname;
}


sub main
{
    # get arguments
    my $args = parse_cgiargs();
    
    # get unique dirname
    my $unique_dirname = get_unique_dirname($args);
    if ($unique_dirname ne "")
    {
    my $fullname      = $args->{'bc1fullname'};
    my $contact_email = $args->{'bc1contactemail'};     
    my $about_desc    = $args->{'bc1aboutdesc'};
    my $src_format    = $args->{'bc1srcformat'};
    my $file_or_url   = $args->{'bc1fileorurl'};
    my $input_dir     = $args->{'bc1inputdir'};
    my $copy_dir      = $args->{'bc1copydir'};
    my $in_gsdl_area  = $args->{'bc1ingsdlarea'};
    my $acronyms      = $args->{'bc1acronyms'};

    my $cmd = "perl ";
    $cmd .= &util::filename_cat($ENV{'GSDLHOME'}, "bin", "script", "mkcol.pl");
    $cmd .= " -title   \"$fullname\"";
    $cmd .= " -creator $contact_email";
    $cmd .= " -about   \"$about_desc\"";
    $cmd .= " -plugin  \"GMLPlug\"";
    $cmd .= " -plugin  \"${src_format}Plug\"";
    $cmd .= " -plugin  \"ArcPlug\"";
    $cmd .= " -plugin  \"RecPlug\"";
### $cmd .= " -refine  \"$refine_plugs\"";
    $cmd .= " $unique_dirname";

    my $status = system($cmd);
    $status /= 256;

    if ($status == 0)
    {
        # append copydir, file_or_url and input_dir to end of collect.cfg
        # we'll also append DocumentUseHTML if processing HTML docs
        my $cfg_filename 
        = &util::filename_cat($ENV{'GSDLHOME'},"collect",$unique_dirname,
                      "etc","collect.cfg");
        if (open(CFGAPP,">>$cfg_filename"))
        {
        if (&gflock::lock (CFGAPP)) {
            print CFGAPP "\n";

            if ($src_format eq "HTML") {
            print CFGAPP "format\tDocumentUseHTML\ttrue\n\n";
            }

            print CFGAPP "building\tfileorurl\t$file_or_url\n";
            print CFGAPP "building\tinputdir\t$input_dir\n";
            print CFGAPP "building\tcopydir\t\t$copy_dir\n";
            print CFGAPP "building\tingsdlarea\t$in_gsdl_area\n";
            &gflock::unlock (CFGAPP);
            close(CFGAPP);
        }
        else
        {
            # problem locking file
            my $mess = "Unable to lock collection";
            $mess .= " configuration file: $cfg_filename";
            &webpageutil::error_location($args,$mess);
            close(CFGAPP);
            return;
        }
        }
        else
        {
        # problem
        my $mess = "Unable to append to collection";
        $mess .= " configuration file: $cfg_filename";
        &webpageutil::error_location($args,$mess);
        return;
        }
    }
    else
    {
        my $mess = "An error was encountered: error status = $status";
        &webpageutil::error_location($args,$mess);
        return;
    }
    }
    else
    {
    my $mess = "No unique directory name specified for collection";
    &webpageutil::error_location($args,$mess);
    return;
    }

    my $mess_url = "$args->{'httpbuild'}&bca=mess&bc1dirname=$unique_dirname";
    print "Location: $mess_url&head=_headdone_&mess=_messdonenewcol_\n\n";

}

&main();