Re: Re: staging/live approval not working

#!/usr/bin/perl -w

#-----------------------------------------------------------------------------------------------------------
#	File: remove_unapproved_withsg_i18n.pl
#
#	   Parser for xml files exported by repligard.  
#          Removes unapproved (or changed after approve) entries
#
#          Sitegroups AND Multilang enabled version
#
#       By: "Eero 'Rambo' af Heurlin" <rambo-ZpG/[email protected]>
#
#-----------------------------------------------------------------------------------------------------------

use strict;
use utf8;
use XML::Parser::Expat;
use Time::Local;
use Getopt::Std;

# Get the file name from the command line
my %Opts;
getopt('', \%Opts);
# foreach my $kkk (keys %Opts) {
#         print "DEBUG: option $kkk=".$Opts{$kkk}."\n";
# }

my $skip_pages=$Opts{p};
my $skip_articles=$Opts{a};
my $skip_snippetdirs=$Opts{d};
my $skip_styles=$Opts{s};
my $check_sg0=$Opts{r};

my $file = $ARGV[0] || die( &usage );

# Some bit buckets
my $current_id = "";
my $cur_content = "";
my $obj_content = "";
my $current_obj_type = "";
my %current_obj_data;
my $start = "";
my $end = ""; 
my $cnt = 0;
my $dom = "";
my $nam = "";
my $val = "";

# Some arrays (or actually hashes on perl language) for data jugling
my %base_objects; # Keys are GUIDs, values are second level hashes matching midgard object structure
my %parameters;   # -- '' --
my %blobs;        # -- '' --
my %xml_data;     # Keys are GUIDs, values are the actual XML data (including the start and end tags, which include the GUID again
my %parametermap; # Keys are GUIDs (for matching to the %base_objects) values are second level arrays that have as value the GUID of the parameter
my %blobmap;      # -- '' -- (naturally for blob)

# Define which objects are children to "base objects"
my %child_object_names;
$child_object_names{"BLOBS"}=1;
$child_object_names{"RECORD_EXTENSION"}=1;


my $parser = new XML::Parser::Expat;

# Set up the handlers for the parser
$parser->setHandlers(	'Start'		=> \&start_handler,
			'End'		=> \&end_handler,
			'Default'	=> \&default_handler);

open(FILE, $file) || die "Couldn't open file $!\n";

$parser->parse(*FILE);

close(FILE);

my $guid="";
# Walk the base objects hash and call check subroutines which determine whether to keep a certain element or not
foreach $guid (keys %base_objects) {
        %current_obj_data=();
        foreach my $k (keys %{$base_objects{$guid}}) {
	        $current_obj_data{$k}=$base_objects{$guid}{$k};
	}
    
#        print "DEBUG: object type: ".$current_obj_data{"__TABLE__"}.", deleted: ".$current_obj_data{"__DELETED__"}."\n";
    
        if (!$current_obj_data{"__DELETED__"}) {
	   if (clean_tag_simple($current_obj_data{"sitegroup"}) or $check_sg0) { # Do not clean SG0 objects by default
              my $type=uc($current_obj_data{"__TABLE__"});
              if ($type eq "ARTICLE") {
  	         check_article($guid, %current_obj_data);  
	      } 
              elsif ($type eq "PAGE") {
	         check_page($guid, %current_obj_data);
	      }
              elsif ($type eq "STYLE") {
	         check_style($guid, %current_obj_data);
	      }
              elsif ($type eq "SNIPPETDIR") {
	         check_snippetdir($guid, %current_obj_data);
	      }
	   }
	}
    
}



open (OUTFILE, ">$file.cleaned") || die "Couldn't open $file.cleaned $!\n";
print OUTFILE "$start\n"; 
for my $k (keys %xml_data) {
    print OUTFILE $xml_data{$k};
}
print OUTFILE "\n$end";
print OUTFILE "\n";


close OUTFILE;

 unlink $file || die "could not delete $file : $!";
 rename ("$file.cleaned", "$file") or die "could not rename $file.cleaned : $!";

#-----------------------------------------------------------------------------------------------------------
#	Sub routines
#-----------------------------------------------------------------------------------------------------------

sub check_article {
    if ($skip_articles) { return 1; }
    my ($l_guid, %current_obj_data) = @_;
#    print "DEBUG: check_article l_guid: $l_guid\n";
    my $astamp=repligard_string_to_time(clean_tag_simple($current_obj_data{"approved"}));
    my $rstamp=repligard_string_to_time(clean_tag_simple($current_obj_data{"revised"}));
#    print "DEBUG: astamp=$astamp, rstamp=$rstamp\n";
    # Simple revised > approved check
    if ($rstamp > $astamp) { remove_obj($l_guid); }
    # Timed checks
    $dom="";
    $nam="";
    $val="";
    my @paramdata=(0,0,0,0);
    foreach my $kk (values %{$parametermap{$l_guid}}) {
	    $dom=clean_tag_cdata($parameters{$kk}{"domain"});
	    if ($dom eq "approve_time") {
  	       $nam=clean_tag_cdata($parameters{$kk}{"name"});
	       $val=clean_tag_cdata($parameters{$kk}{"value"});
#	       print "DEBUG: dom=$dom, name=$nam, val=$val\n";
	       if ($nam eq "endhours") {
		  $paramdata[0]=$val;
	       } elsif ($nam eq "endminutes") {
		  $paramdata[1]=$val;
	       } elsif ($nam eq "starthours") {
		  $paramdata[2]=$val;
	       } elsif ($nam eq "startminutes") {
		  $paramdata[3]=$val;
	       }
	    }
    }
    my $atstart_str=clean_tag_simple($current_obj_data{"calstart"})." ".sprintf("%02d", $paramdata[2]).":".sprintf("%02d", $paramdata[3]).":00";
    my $atstart=repligard_string_to_time($atstart_str);
    my $atend_str=clean_tag_simple($current_obj_data{"calstart"})." ".sprintf("%02d", $paramdata[0]).":".sprintf("%02d", $paramdata[1]).":00";
    my $atend=repligard_string_to_time($atend_str)+(24*3600*clean_tag_simple($current_obj_data{"caldays"}));
#    print "DEBUG: atstart=$atstart atend=$atend \n";
    if ($atstart) { # Check if we have reached timed approve start time
       if (time() < $atstart) { remove_obj($l_guid); }
    }
    if ($atend > $atstart) { # Check if there is end time set to approval and if we have reached it
       if (time() > $atend) { remove_obj($l_guid); }
    }
}

sub check_page {
    if ($skip_pages) { return 1; }
    my ($l_guid, %current_obj_data) = @_;
    check_generic($l_guid, %current_obj_data);
}    

sub check_style {
    if ($skip_styles) { return 1; }
    my ($l_guid, %current_obj_data) = @_;
    check_generic($l_guid, %current_obj_data);
}    

sub check_snippetdir {
    if ($skip_snippetdirs) { return 1; }
    my ($l_guid, %current_obj_data) = @_;
    check_generic($l_guid, %current_obj_data);
}    


sub check_generic {
    my ($l_guid, %current_obj_data) = @_;
    my @paramdata=(0,0);
    foreach my $kk (values %{$parametermap{$l_guid}}) {
	    $dom=clean_tag_cdata($parameters{$kk}{"domain"});
	    if ($dom eq "approval") {
  	       $nam=clean_tag_cdata($parameters{$kk}{"name"});
	       $val=clean_tag_cdata($parameters{$kk}{"value"});
#	       print "DEBUG: dom=$dom, name=$nam, val=$val\n";
	       if ($nam eq "startdate") {
		  $paramdata[0]=$val;
	       } elsif ($nam eq "status") {
		  $paramdata[1]=$val;
	       }
	    }
    }
    my ($sdate, $status)=@paramdata;
    if (($status eq "always") | ($status eq "now")) { return 1; }
    if ((!$status) | ($status eq "not") | ($status eq "change")) { 
       remove_obj($l_guid);
    }
    if (($status eq "startdate") & (time() < $sdate)) {
       remove_obj($l_guid);
    }
}


sub repligard_string_to_time {
    my ($str) = @_;
    $_ = $str;
    my ($year, $month, $day, $hour, $min, $sec) = /(\d{4,4})-?(\d{2,2})-?(\d{2,2})\s?(\d{2,2}):?(\d{2,2}):?(\d{2,2})/;
#    print "DEBUG: str=\"$str\" year=$year, month=$month, day=$day, hour=$hour, min=$min, sec=$sec\n";
    if (($day>=1) & ($month>=1) & ($year>=1)) {
       return timelocal($sec,$min,$hour,$day,$month-1,$year); # timelocal uses 0 based months...
    } else { 
       return 0;
    }
}

sub clean_tag_simple {
    my ($str) = @_;
#    print "DEBUG: str=\"$str\"\n";
    $_=$str;
    my ($tag, $ret)=/<([^>]+)>([^<]+)<[^>]+>/;
#    print "DEBUG: tag=$tag, ret=$ret\n";
    return $ret;
}

sub clean_tag_cdata {
    my ($str) = @_;
#   print "DEBUG clean_tag_cdata: str=\"$str\"\n";
    $_=$str;
    my ($ret)=/<[^>]+>(.*)<[^>]+>/;
#   print "DEBUG clean_tag_cdata: phase 1 \"$ret\"\n";
    $_=$ret;
    ($ret)=/<!\[CDATA\[(.*)\]\]>/;
#   print "DEBUG clean_tag_cdata: phase 2 \"$ret\"\n";      
    return $ret;
}


sub remove_obj {
    my ($l_guid) = @_;
    # Remove the object from XML data
    delete ($xml_data{$l_guid});
    # Remove object parameters
    foreach my $kk (values %{$parametermap{$l_guid}}) {
	    delete ($xml_data{$kk});
    }
    # Remove object attachments
    foreach my $kk (values %{$blobmap{$l_guid}}) {
	    delete ($xml_data{$kk});
    }
    
    # Remove direct child objects like (page-)elements and snippets
    if (uc($base_objects{$l_guid}{"__TABLE__"}) eq "PAGE") {
	remove_children("PAGEELEMENT", "page", $l_guid);
    } elsif (uc($base_objects{$l_guid}{"__TABLE__"}) eq "ARTICLE") {
	# Multilang articles
	remove_children("ARTICLE_I", "sid", $l_guid);
    } elsif (uc($base_objects{$l_guid}{"__TABLE__"}) eq "STYLE") {
	remove_children("ELEMENT", "style", $l_guid);
    } elsif (uc($base_objects{$l_guid}{"__TABLE__"}) eq "SNIPPETDIR") {
	remove_children("SNIPPET", "up", $l_guid);
    }
    

}

sub remove_children {
    my ($check_child_table, $check_child_link, $l_guid)=@_;
    if ($check_child_table & $check_child_link) {	
        foreach my $ll_guid (keys %base_objects) {
                my %ll_current_obj_data=();
                foreach my $kk (keys %{$base_objects{$ll_guid}}) {
	                $ll_current_obj_data{$kk}=$base_objects{$ll_guid}{$kk};
		}
	        if (!$ll_current_obj_data{"__DELETE__"} & (uc($ll_current_obj_data{"__TABLE__"}) eq uc($check_child_table))) {
		   if (clean_tag_simple($ll_current_obj_data{$check_child_link}) eq $l_guid) {
		      remove_obj($ll_guid);
		   }
		}
	}
    }    
}

sub start_handler {
	my ($p, $element, %attributes) = @_;
        my @context_list=$p->context();
        my $d=$p->depth();
        my $context="";
        if ($d > 0) {
           $context=uc($context_list[$d-1]);
	   if ($context eq "DATABASE") {
	      $current_obj_type=uc($element);
	      $current_obj_data{"__TABLE__"}=$element;
	      $current_obj_data{"id"}=$attributes{"id"};
	      $current_obj_data{"__DELETED__"}='';
	      if ($attributes{"deleted"}) {
  	         $current_obj_data{"__DELETED__"}=$attributes{"deleted"};
	      }
	      $current_id=$attributes{"id"};
	   }
	}

#        print "DEBUG: start element: \"$element\" depth: $d context: \"$context\" current_obj_type: \"$current_obj_type\" \n";

        if( uc( $element ) eq "DATABASE" ){
		$start = $cur_content.$p->recognized_string();
#	        print "DEBUG-XML: \"$start\"\n";
	        $cur_content="";
	}
	else {
	   
	       $cur_content .= $p->recognized_string();
	}
}


sub end_handler {
	my ($p, $element) = @_;
        my @context_list=$p->context();
        my $d=$p->depth();
        my $context="";
        if ($d > 0) {
           $context=uc($context_list[$d-1]);
	}

#        print "DEBUG: end element: \"$element\" depth: $d context: \"$context\" current_obj_type: \"$current_obj_type\" \n";


	if( uc( $element ) eq "DATABASE" ){
		$end = $cur_content.$p->recognized_string();
# 	        print "DEBUG-XML: \"$end\"\n";
	        $cur_content="";
	}
	else{
	    
	     $cur_content .= $p->recognized_string();

	     $obj_content .= $cur_content;
	     if (uc($element) eq $current_obj_type) { # End tag for object
#		print "DEBUG-XML: \"$obj_content\" \n";
		 
		if (!$child_object_names{$current_obj_type}) {
		   # %base_objects{$current_id}=%current_obj_data;
		   for my $k (keys %current_obj_data) {
		       $base_objects{$current_id}{$k}=$current_obj_data{$k};
		       for ($base_objects{$current_id}{$k}) {
			      s/^\s+//;
			      s/\s+$//;
		       }  
		   }
		} else {
		   if ($current_obj_type eq "RECORD_EXTENSION") {
 		      # %parameters{$current_id}=%current_obj_data;
 		      for my $k (keys %current_obj_data) {
		          $parameters{$current_id}{$k}=$current_obj_data{$k};
		          for ($parameters{$current_id}{$k}) {
			      s/^\s+//;
			      s/\s+$//;
		          }  
		      }
		      if (!$current_obj_data{"__DELETED__"}) {
  		         $_=$current_obj_data{"oid"};
		         my ($boguid)=/<oid>([^<]*)<\/oid>/;
#			 print "DEBUG: record_ext parent GUID: $boguid \n";
		         # TODO: place current guid to parametermap
                         $cnt=0;
                         foreach my $k (keys %{$parametermap{$boguid}}) {
			         $cnt++;
			 }
#			 print "DEBUG: count: $cnt \n";
			 $parametermap{$boguid}{$cnt}=$current_id;
		      }
		   } else {
		      # %blobs{$current_id}=%current_obj_data;
		      for my $k (keys %current_obj_data) {
		          $blobs{$current_id}{$k}=$current_obj_data{$k};
		          for ($blobs{$current_id}{$k}) {
			      s/^\s+//;
			      s/\s+$//;
		          }  
		      }
		      if (!$current_obj_data{"__DELETED__"}) {
                         $_=$current_obj_data{"pid"};
		         my ($boguid)=/<pid>([^<]*)<\/pid>/;
#			 print "DEBUG: blob parent GUID: $boguid \n";
		         # TODO: place current guid to blobmap
			 $cnt=0; 
                         foreach my $k (keys %{$blobmap{$boguid}}) {
			         $cnt++;
			 }
#			 print "DEBUG: count: $cnt \n";
			 $blobmap{$boguid}{$cnt}=$current_id;
		      }
		   }
		}
		
		$xml_data{$current_id}=$obj_content;
		 
		$obj_content = "";
		$current_id = "";
		$current_obj_type="";
		%current_obj_data=();

	     } else {
		$current_obj_data{$element}=$cur_content;
	     }

	     $cur_content="";
	}
} 

sub default_handler {
	my ($p, $string) = @_;
	$cur_content .= $string;
} 


sub usage {
	print<<EOP;
remove_unapproved.pl [options] <filename>
  options:
      -p don't check page approvals
      -s don't check style approvals
      -d don't check snippetdir approvals
      -a don't check article approvals
      -r check also SG0 object approvals
EOP
}

#-----------------------------------------------------------------------------------------------------------