#!/usr/bin/perl -w # -*- mode: perl -*- # GIFT, a flexible content based image retrieval system. # Copyright (C) 1998, 1999, 2000, 2001, 2002, CUI University of Geneva # 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # This script makes GIFT index all images in a directory # afterwards it creates an entry in the gift config file. # use XML::DOM; use XML::XQL; use XML::XQL::DOM; use Getopt::Long; use IO::File; use XML::Writer; use POSIX; use File::Find; use File::Path; use File::Copy; use Text::Iconv; use POSIX qw(tmpnam); use strict; use vars qw($self $llTemp $llFullName $lFullName $lName $lExtension *FH $lCountPotentialImages $lCountVisitedImages $lImageDirectory $lImageDirectory $lCollectionName $lFeaturePrefix $lIndexPrefix $lThumbnailDirectory $lURLPrefix $lThumbnailURLPrefix $gGiftHome $OLDCONFIG $CONFIG $lOptionList %lOptions $i $lIndexPrefix $url2fts_name $URL2FTS $lURL $lFts $lThumbnailURL $lThumbnailFile $gStringConverter $gDoRemove $gDoFixConfig ); # # first: get the options given on the command line # %lOptions=(); GetOptions(\%lOptions, "fix-config", "help", "remove-collection", "gift-home=s", "local-encoding=s", "image-directory=s", "collection-name:s", "feature-prefix:s", "index-prefix:s", "url-prefix:s", "thumbnail-dir:s", "thumbnail-url-prefix:s", "no-png", "no-gif", "no-jpg", "no-nps", "no-ps"); my($lInEncoding,$lOutEncoding)=((!(defined($lOptions{"local-encoding"}))) ? (&main::findOutEncodings()) : ($lOptions{"local-encoding"},"UTF-8")); print "I am assuming that the system is using $lInEncoding as encoding. Within the xml files generated, we will use $lOutEncoding as encoding method\n"; $gStringConverter = Text::Iconv->new($lInEncoding,$lOutEncoding); # # second: read the options from the .gift-add-collection file # we look for this file in the GIFT_HOME directory # local $gDoFixConfig=""; local $lImageDirectory=""; local $lCollectionName=""; local $lFeaturePrefix=""; local $lIndexPrefix=""; local $lThumbnailDirectory=""; local $lURLPrefix=""; local $lThumbnailURLPrefix=""; local $gGiftHome= $lOptions{'gift-home'} || $gGiftHome || $ENV{GIFT_HOME} || $ENV{HOME}; local $gDoRemove=""; local $lOptionList={ "fix-config" => \$gDoFixConfig, "remove" => \$gDoRemove, "gift-home" => \$gGiftHome, "image-directory" => \$lImageDirectory, "collection-name" => \$lCollectionName, "feature-prefix" => \$lFeaturePrefix, "index-prefix" => \$lIndexPrefix, "thumbnail-dir" => \$lThumbnailDirectory, "url-prefix" => \$lURLPrefix, "thumbnail-url-prefix" => \$lThumbnailURLPrefix }; unless(open DOT_FILE,"$ENV{HOME}/.gift-add-collection"){ print STDERR "File $ENV{HOME}/.gift-add-collection could not be opened ($!), so I won't use it\n"; }else{ { while () { chomp; foreach $i (keys %$lOptionList) { next if m/^\#/; #skip comments eval("if(m/^$i=\\\"(.*)\\\"/){\${\$lOptionList->{\$i}}=\$1;}"); } } foreach $i (keys %$lOptionList) { print "$i => ${$lOptionList->{$i}}\n" if $ {$lOptionList->{$i}}; } ; } } # do we want to remove a collection if($lOptions{'remove-collection'}){ $gDoRemove=1; } # do we want to remove a collection if($lOptions{'fix-config'}){ $gDoFixConfig=1; } # # # #unless($gDoRemove)$gGiftHome= $lOptions{'gift-home'} || $gGiftHome || $ENV{GIFT_HOME} || $ENV{HOME}; # # old position of copy gift-config.mrml and write gift-embed-perl-modules # $lImageDirectory= $lOptions{'image-directory'} || $ARGV[0] || $lImageDirectory || $ENV{PWD} ; $lImageDirectory=$ENV{PWD}.$lImageDirectory unless $lImageDirectory=~m[^/]; $lImageDirectory=$lImageDirectory."/"; $lImageDirectory=~s[ /+ ][/]gx; #removing double backslashes in the end $lImageDirectory=~s[^([^/])][$ENV{PWD}/$1]x; #making path absolute #take the last bit of the directory as database name $lCollectionName= $lOptions{'collection-name'} || $lCollectionName || (split("/",$lImageDirectory))[-1]; #$lCollectionName=~s§$gGiftHome§§; $lFeaturePrefix= $lOptions{'feature-prefix'} || $lFeaturePrefix || "$gGiftHome/gift-indexing-data/$lCollectionName/"; $lURLPrefix= $lOptions{'url-prefix'} || $lURLPrefix || "file:$lImageDirectory"; # is the urlprefix in ~/public_html? create a http-url! $lURLPrefix=~s[^file:/var/www/gnuift/][http://localhost/gnuift//]; if ($lOptions{'thumbnail-dir'}) { $lThumbnailDirectory= $lOptions{'thumbnail-dir'} || $lThumbnailDirectory; $lThumbnailDirectory=~s[ /+$ ][/]x; #removing double backslashes in the end $lThumbnailDirectory=~s[^([^/])][$ENV{PWD}/$1]x; #making path absolute } else { unless($lThumbnailDirectory){ $lThumbnailDirectory= $lImageDirectory ; $lThumbnailDirectory=~s[ /*$ ][_thumbnails]x; #strip trailing slashes and add thumbnails } } #$lThumbnailURLPrefix= $lOptions{'thumbnail-url-prefix'} || $lOptions{'url-prefix'} || "file:$lThumbnailDirectory"; $lThumbnailURLPrefix= $lOptions{'thumbnail-url-prefix'} || $lThumbnailURLPrefix || $lOptions{'url-prefix'} || $lURLPrefix || "file:$lThumbnailDirectory"; #cleanup: if there is no "thumbnails" in the end of the url, # but there is thumbnails in the end of the directory # automatically add that if(($lThumbnailDirectory=~m/_thumbnails$ /x) && (!($lThumbnailURLPrefix=~m[^(.*)_thumbnails/*$ ]x))){ $lThumbnailURLPrefix=~s[/*$ ][_thumbnails/]x; } # is the thumbnail-urlprefix in ~/public_html? create a http-url! $lThumbnailURLPrefix=~s[^file:/var/www/gnuift/][http://localhost/gnuift//]; $lIndexPrefix= $lOptions{'index-prefix'} || $lIndexPrefix || $lFeaturePrefix; # we asume that the lIndexPrefix ends with # a "/" throughout the program $lIndexPrefix.="/" unless($lIndexPrefix=~m[ /$ ]x); # # replace variables: # foreach $i (values %$lOptionList) { $$i=~s/address@hidden@/$lCollectionName/g; } if ($lOptions{help}) { print " gift-add-collection [options] [image-directory]: Add an image collection to your gift database. THE FOLLOWING LIST OF OPTIONS ALSO SHOWS THE CURRENT VALUES AND TAKES OPTIONS BESIDES --help INTO ACCOUNT. IT IS A USEFUL TOOL FOR FINDING OUT HOW gift-add-collection WORKS. Options (options override .gift-add-collection entries): --gift-home Specify the directory which contains the configuration to which you are adding a collection. By default either GIFT_HOME (current value \"$ENV{GIFT_HOME}\") or HOME (current value \"$ENV{HOME}\"). The current value is \"$gGiftHome\" --image-directory All images in this directory will be indexed. Same as giving image-directory after the options Default: \$PWD, Current value: $lImageDirectory --collection-name Name of the new collection to be generated. Default is full path of the image directory. Current value: $lCollectionName --feature-prefix Feature data will be written into this directory. Current value: $lFeaturePrefix --index-prefix Indexing data will be written into this directory Default: $lIndexPrefix (in general:same as given by --feature-prefix) --thumbnail-dir Thumbnails will be put into this directory: Current value: $lThumbnailDirectory (in general:same as given by the name 'image-directory'_thumbnails) Current value: $lThumbnailDirectory --fix-config Fixes the config file by adjusting the collection used by the default query algorithm. If GIFT complains to you about an unknown collection with ID __COLLECTION__, that's the thing to do. Change here, if you want to make a database accessible from the WWW --url-prefix This URL-trunc will be prepended to the file names generated. Default: file:-URL to images Current value: $lURLPrefix --thumbnail-url-prefix This URL-trunc will be prepended to the thumbnail file names generated. file:-URL to thumbnails Current value: $lThumbnailURLPrefix If this script recognizes that you are indexing files in public_html, it will automatically generate http://localhost/~$ENV{HOME} URLs. Options override the contents of $ENV{HOME}/.gift-add-collection "; exit 0; } unless(-e "$gGiftHome/gift-config.mrml"){ copy("/usr/share/gift-config.mrml", "$gGiftHome/gift-config.mrml"); } unless(-e "$gGiftHome/gift-embed-perl-modules.pl"){ open PM_OUTFILE,">$gGiftHome/gift-embed-perl-modules.pl" or die "Could not write file $gGiftHome/gift-embed-perl-modules.pl"; print PM_OUTFILE " # # This file was automatically generated # by the GNU Image-Finding Tool (GIFT). # # It should contain 'use' instructions for ALL modules # you want to use from within the GIFT. # # You also have to add 'use lib' instructions where # necessary # use lib '/usr/bin'; use CGIFTLink; "; } mkpath([$lThumbnailDirectory],1,0755); mkpath([$lIndexPrefix,$lFeaturePrefix],1,0711); print " I will read the images in: $lImageDirectory I will generate feature files which I put into: $lFeaturePrefix The index files will be stored in: $lIndexPrefix The URLs I will generate will have the prefix: $lURLPrefix "; unless($gDoRemove || $gDoFixConfig){ $url2fts_name=">${lIndexPrefix}/url2fts.xml"; $URL2FTS=new IO::File($url2fts_name) or die "Could not open database $url2fts_name for output!"; local $self={}; $self->{writer}=new XML::Writer( OUTPUT => $URL2FTS, DATA_MODE => 1, DATA_INDENT => 2 ); $self->{writer}->xmlDecl("UTF-8","yes"); $self->{writer}->startTag("image-list"); $main::lImageCount=0; $main::gModifyingDateOfThis=(stat($0))[9]; print "This file was last modified $main::gModifyingDateOfThis after the epoch\n"; print "Estimating how many images we are going to index: "; $lCountPotentialImages=0; find(\&countPotentialImages,$lImageDirectory); print "$lCountPotentialImages\n"; $lCountVisitedImages=0; find(\&wanted,$lImageDirectory); $self->{writer}->endTag("image-list"); $URL2FTS=0; #close the file sub countPotentialImages{ my $lFullName=$File::Find::name; my $lName=$lFullName; $lName=~m§\.([^\.]*)$§; my $lExtension=$1; if ($lExtension && $lExtension=~m/^((tif)|(tiff)|(ppm)|(gif)|(jpg)|(jpeg)|(eps)|(png)|(ras))$ /xi) { $main::lCountPotentialImages++; } } sub wanted{ local $lFullName=$File::Find::name; local $lName=$lFullName; $lName=~s[^$lImageDirectory][]; $lName=~m§\.([^\.]*)$§; local $lExtension=$1; if ($lExtension && $lExtension=~m/^((tif)|(tiff)|(ppm)|(gif)|(jpg)|(jpeg)|(eps)|(png)|(ras))$/i) { eval{ my $lNameBase=$lName; $lNameBase=~s§\.$lExtension$§§; $lURL="$lURLPrefix/$lName"; $lFts="$lFeaturePrefix/${lNameBase}_$lExtension.fts"; #the actual location of the thumbnail $lThumbnailFile="$lThumbnailDirectory/${lNameBase}_thumbnail_$lExtension.jpg"; $lThumbnailURL ="$lThumbnailURLPrefix/${lNameBase}_thumbnail_$lExtension.jpg"; print "$lURL $lFts\n"; my $lURL2FTSLine="$lURL $lThumbnailURL $lFts\n"; $lURL2FTSLine=~s§/+§/§g; $lURL2FTSLine=~s§http:/§http://§g; my $i; foreach $i ($lURL, $lThumbnailURL) { #escaping the URL $i=~s[//][/]g; $i=~s[^http:/][http://]; $i=~s[ ][%20]g; $i=safeConvertString($i); } #print "This script was last modified on $main::gModifyingDateOfThis\n"; #print "lURLPrefix: $lURLPrefix lNameBase: $lNameBase lExtension: $lExtension\n"; # uniqueness of names given by process id # the variable containing the process id of this script # is $$ my $lTemp="/tmp/gift_tmp$$.ppm"; my $lTempFts="/tmp/gift_tmp$$.fts"; my $lThumbnailModificationTime=(stat($lThumbnailFile))[9]; # note: i removed time stamp checking, so that regens were quick. if (!-e($lThumbnailFile)) { $lThumbnailFile=~m§^(.*/)([^/]*)$§; print($lThumbnailModificationTime," is the modifying date of $lThumbnailFile\n") if $lThumbnailModificationTime; print("We will make a new thumbnail file\n"); print("making the path $1\n"); mkpath([$1],1,0711); print("Converting $lFullName to $lThumbnailFile\n"); print STDERR "Warning: Thumbnail generation failed for $lThumbnailFile $!\n" if system("convert", "-geometry", "128x128", $lFullName, $lThumbnailFile); } else { print "Warning: more recent version of thumbnail file $lThumbnailFile found!\n"; } # resize the image. if ((!$main::lImageCount) || (!-e($lFts))) { print("Converting $lFullName to $lTemp\n"); unlink $lTemp; local $llTemp=$lTemp; local $llFullName=$lFullName; eval{ if (system("convert" , "-geometry", "256x256!", $llFullName, $llTemp)) { print "Pre feature extraction convert call returned nonzero: $! \n",join(" ",("convert" , "-geometry", "256x256!", $llFullName, $llTemp,"\n")); } }; unless(-e($lTemp)){ die "Pre feature extraction convert call failed ",join(" ",("convert" , "-geometry", "256x256!", $llFullName, $llTemp,"\n")) ; } } my $lFtsModificationTime=(stat($lFts))[9]; if (-e($lFts)) { #dont, and say we did. if (!$main::lImageCount) { system qq(/usr/bin/gift-write-feature-descs < $lTemp |perl -e 'print "Writing InvertedFileFeatureDescription...\n";open OF,">$main::lIndexPrefix/InvertedFileFeatureDescription.db" or die "could not open $lIndexPrefix";while(){print OF join(" ",(split(" ",\$_))[0..1]),"\\n";};print "finished.\n";' ); unlink $lTemp; } $main::lImageCount++; $main::lCountVisitedImages++; print "creating no feature file, file found.\n"; print "\nPROGRESS: ".$main::lCountVisitedImages." of ".$main::lCountPotentialImages." done (".POSIX::floor(90*$main::lCountVisitedImages/$main::lCountPotentialImages)."%)\n"; } else { #actually perform feature extraction if ($lFtsModificationTime) { print($lFtsModificationTime," is the modifying date of $lFts file\n") } print("We will make a new feature file\n"); print("Extracting features from $lTemp\n"); unlink($lTempFts); eval{ system("/usr/bin/extract_features $lTemp"); }; if(-e $lTempFts){ $lFts=~m§^(.*/)([^/]*)$§; print("making the path $1\n"); mkpath([$1],1,0711); print("...copying from $lTempFts to $lFts\n\n"); copy($lTempFts,$lFts) or print STDOUT "\nCopy $lTempFts -> $lFts failed: $!\n"; if (!$main::lImageCount) { system qq(/usr/bin/gift-write-feature-descs < $lTemp |perl -e 'print "Writing InvertedFileFeatureDescription...\n";open OF,">$main::lIndexPrefix/InvertedFileFeatureDescription.db" or die "could not open $lIndexPrefix";while(){print OF join(" ",(split(" ",\$_))[0..1]),"\\n";};print "finished.\n";' ); } $main::lImageCount++; $main::lCountVisitedImages++; # print "Number of images: $main::lImageCount\n\n"; unlink($lTemp); unlink($lTempFts); print "\nPROGRESS: ".$main::lCountVisitedImages." of ".$main::lCountPotentialImages." done (".POSIX::floor(90*$main::lCountVisitedImages/$main::lCountPotentialImages)."%)\n"; } else { print "warning: Feature extraction of $lTemp to $lTempFts failed!\n"; } } # 2004-03-18 add attribute line as last thing my $lAttributes={ "url-postfix" => $lURL, "thumbnail-url-postfix" => $lThumbnailURL, "feature-file-name" => safeConvertString($lFts) }; $self->{writer}->emptyTag("image",(%{$lAttributes})); }; if ($@) { print STDERR "There was an error in extracting features from $File::Find::name\n"; } } } #i am looking for a match of this to place the newly made data my $lTheLine=''; close URL2FTS; system("/usr/bin/gift-generate-inverted-file $lIndexPrefix/"); print "\nPROGRESS: 99%\n"; my $lUniqueCollectionID="c-".join("-",gmtime()); { #rescue the old config $CONFIG="$gGiftHome/gift-config.mrml"; $OLDCONFIG="${CONFIG}-old"; copy($CONFIG,$OLDCONFIG); print " Copying $CONFIG to $OLDCONFIG "; #before overwriting it with the new config my $lParser = new XML::DOM::Parser; my $lGIFTConfig = $lParser->parsefile ("$gGiftHome/gift-config.mrml") or die $!; if(0){ $CONFIG=">$CONFIG"; open OLDCONFIG or die "COULD NOT OPEN $OLDCONFIG"; open CONFIG or die "COULD NOT OPEN $CONFIG"; while () { if (m/$lTheLine/) { print CONFIG qq( \n\n); } s/\_\_COLLECTION\_\_/$lUniqueCollectionID/g; } }else{ my $lString=&safeConvertString(qq( \n\n)); #WORKAROUND: apparently under perl 5.8.0 XML::DOM::Parse has a problem # when parsing from strings. Solution: 1. write to a temporary file # 2. parse the file. 3. delete the file. my $lName=""; { do { $lName = tmpnam(); } until sysopen(FH, $lName, O_RDWR|O_CREAT|O_EXCL, 0600); print FH $lString; close FH; } my $lCollection=$lParser->parsefile($lName); unlink $lName; &addCollection(collection=>$lCollection, document=>$lGIFTConfig); &setDefaultCollectionID("collection-id"=>$lUniqueCollectionID, document=>$lGIFTConfig); $lGIFTConfig->printToFile ("$gGiftHome/gift-config.mrml") or die $!; } } #print "The image count: ",$main::lImageCount,"\n"; print "\nPROGRESS: 100%\n"; }else{ # remove a collection # rescue the old config $CONFIG="$gGiftHome/gift-config.mrml"; $OLDCONFIG="${CONFIG}-old"; copy($CONFIG,$OLDCONFIG); print " Copying $CONFIG to $OLDCONFIG "; #before overwriting it with the new config my $lParser = new XML::DOM::Parser; my $lGIFTConfig = $lParser->parsefile ("$gGiftHome/gift-config.mrml") or die $!; &removeCollection("collection-name"=>$lCollectionName, document=>$lGIFTConfig) if $gDoRemove; &fixit("collection-name"=>$lCollectionName, document=>$lGIFTConfig) if $gDoFixConfig; $lGIFTConfig->printToFile ("$gGiftHome/gift-config.mrml") or die $!; } sub findOutEncodings{ my %lFoundEncodings; my $lInEncoding="US-ASCII"; { open LOCALELIST, "locale -m |" or die "$!"; while(){ chomp $_; $lFoundEncodings{$_}=1 if($_); } } { open LOCALELIST, "locale LC_MONETARY |" or die "$!"; while(){ chomp $_; $lInEncoding=$_ if($lFoundEncodings{$_}); } } return(($lInEncoding || "UTF-8"),"UTF-8"); } sub safeConvertString( $ ){ my $lStringCopy=shift; return $gStringConverter->convert($lStringCopy) || $lStringCopy;# is now in UTF-8 or what it was before } # CONFIG SERVER CODE sub setDefaultCollectionID{ my $inParameters={}; address@hidden; # find the attributes collection-id in my(@lToBeChanged)=$inParameters->{document}->xql("/mrml/cui-configuration/algorithm-list/algorithm/address@hidden'__COLLECTION__\'"); my $i; # replace __COLLECTION__ by actual collection ID. foreach $i (@lToBeChanged){ $i->setNodeValue($inParameters->{"collection-id"}); } } sub fixit{ print "Fixing config file by adjusting the collection ID of the default algorithm"; my $inParameters={}; address@hidden; my $lReturnValue={success=>1}; # get a list of collections my(@lCollections)=$inParameters->{document}->xql("/mrml/cui-configuration/collection-list/collection"); #make the first collection a default collection if(@lCollections){# clean out the files mentioned in the collection tag my $lId=$lCollections[0]->getAttribute("collection-id"); $inParameters->{"collection-id"}=$lId; &setDefaultCollectionID((%$inParameters)); }else{ # no collection found --> failure $lReturnValue->{success}=0; } return $lReturnValue; } sub addCollection{ my $inParameters={}; address@hidden; my $lReturnValue={success=>1}; my $lCollectionID=$inParameters->{collection}->getDocumentElement()->getAttribute("collection-id") or die; my $lCollectionName=$inParameters->{collection}->getDocumentElement()->getAttribute("collection-name") or die; my(@lConflict)=$inParameters->{document}->xql("/mrml/cui-configuration/collection-list/collection/address@hidden'$lCollectionName\'"); if(@lConflict){ print join(",",@lConflict); my $lAttributes=$inParameters->{collection}->getDocumentElement()->getAttributes(); my $i; for $i ($lAttributes->getValues( )){ my $lName= $i->getName(); my $lValue= $i->getNodeValue(); print "\n----> $lName $lValue <----"; if($lConflict[0]->getAttribute("$lName")){ unless (($lConflict[0]->getAttribute("$lName") eq $lValue)){ $lReturnValue->{error}="attribute value conflict $lName $lValue\n"; $lReturnValue->{success}=0; last; } }else{ $lConflict[0]->setAttribute("$lName",$lValue); } } if($lReturnValue->{success}){ my @lQueryParadigmLocation=$inParameters->{document}->xql("/mrml/cui-configuration/collection-list/collection/query-paradigm-list"); my $lHasQueryParadigm=scalar(@lQueryParadigmLocation); for $i ($inParameters->{collection}->getChildNodes()){ unless(($i->getNodeName() eq "query-paradigm-list") && $lHasQueryParadigm){ $i->setOwnerDocument($inParameters->{document}); $lConflict[0]->insertBefore($i); } } if($lHasQueryParadigm){# merge two query paradigm lists my $lQPTag=$lQueryParadigmLocation[0]; # find all query paradigms to be added my @lQueryParadigms=$inParameters->{collection}->xql("/mrml/cui-add-collection/collection/query-paradigm-list/*"); #add them to the list #FIXME: there is no elimination of duplicates if(scalar @lQueryParadigms){ my $i; for $i (@lQueryParadigms){ $i->setOwnerDocument($inParameters->{document}); $lQPTag->insertBefore($i); } } } } }else{ my $lCollection=$inParameters->{collection}->getDocumentElement(); $inParameters->{collection}->removeChild($lCollection); $lCollection->setOwnerDocument($inParameters->{document}); my @lInsertLocation=$inParameters->{document}->xql("mrml//collection-list"); $lCollection->setOwnerDocument($inParameters->{document}); unless(@lInsertLocation){ die "Wrong config file format. tag expected => Could not find suitable insert location within config file"; }else{ $lInsertLocation[0]->insertBefore($lCollection); my $lNewLine=$inParameters->{document}->createTextNode("\n"); $lInsertLocation[0]->insertBefore($lNewLine); } } return $lReturnValue; } sub removeCollection{ my $inParameters={}; address@hidden; my $lReturnValue={success=>1}; my $lCollectionName=$inParameters->{"collection-name"}; print "Removing collection with name $lCollectionName\n"; my(@lToBeDeleted)=$inParameters->{document}->xql("/mrml/cui-configuration/collection-list/address@hidden'$lCollectionName\']"); if(@lToBeDeleted){# clean out the files mentioned in the collection tag my $lBaseDirectory=$lToBeDeleted[0]->getAttribute("cui-base-dir"); my $lURL2FTSLocation=$lBaseDirectory."/".$lToBeDeleted[0]->getAttribute("cui-feature-file-location"); unlink($lBaseDirectory."/".$lToBeDeleted[0]->getAttribute("cui-offset-file-location")); unlink($lBaseDirectory."/".$lToBeDeleted[0]->getAttribute("cui-inverted-file-location")); my $lParser= new XML::Parser(Handlers=>{Start => sub{ my $inUserData=shift; my $inElement=shift; my $inAttributes={}; %{$inAttributes}=(@_); print "Clearing out collection $lCollectionName: Deleting ", $inAttributes->{"feature-file-name"},"\n"; unlink $inAttributes->{"feature-file-name"}; unlink $inAttributes->{"feature-file-name"}.".ADI"; }}); unlink $lURL2FTSLocation; # now remove the collection element $lToBeDeleted[0]->getParentNode()->removeChild($lToBeDeleted[0]); my $lURL2FTS= $lParser->parsefile($lURL2FTSLocation); } return $lReturnValue; }