view release on metacpan or  search on metacpan

classgen  view on Meta::CPAN

	my %section;		# contains references to all sections found 
				# in inputfile
	my $new;		# the New-object;
	my @attributes;		# references to all Attribute objects

# --- Program --------------------------------------------------------------	
	# to check the argument line
	$n = @ARGV;
	unless ($n eq 2) {
		print "call:  classgen <input> <output>\n";
	}
	
	# to open the inputfile
	open I,  $ARGV[0]    or die "can not open input file >>$ARGV[0]<< $!";
	
	# output file has to be opened later to allow the archive functions
#	open O, ">$ARGV[1]" or die "can not open output file >>$ARGV[1]<< $!";

   # -- create .gs filename
	my ($gs)=split /\./, $ARGV[1];
#	$gs.=".gs"; print $gs; print "\n";
	$gs.="_gs.pm";
	print $gs; print "\n";
	
#	open GS, ">$gs" or die "can not open .gs file >>$gs<< $!";
	
	my $pm=$ARGV[1];		# 16.12.2000

	# to find the various sections in the inputfile
	check_of_sections();		# to make sure every section is there
	get_sections();

	# to initiate New and Attribute
	init_attributes();
	init_new();			# must be done after init_attributes()
	
	archive($pm, $gs);	# to envoke the archive functions
	check_manifest($gs);	# to include the gs-file, if necessary	
	
	open O, ">$ARGV[1]" or die "can not open output file >>$ARGV[1]<< $!";
	open GS, ">$gs" or die "can not open .gs file >>$gs<< $!";
	
	# to write the various parts of the new class
	write_beginning($VERSION, $gs);
	write_new();
	write_methods();
	write_end();
	
	print "\nrun 'perldoc perlpod' to for details on the perlpod skeleton\n";
	
	
# -----------------------------------------------------------------------------

sub archive {	# to archive previous versions of classes and control files
	my ($pm, $gs)=@_;
	my $ar="archive";
	if(!opendir AR, $ar) {
		mkdir $ar, 0755;	# for some reason 0755 does not work
		opendir AR, $ar;
	}
	chmod 0755, $ar;		# set correct mode
	
	my $n_max=getmax(readdir AR);
	my $new_pm=$ar . "/" . $n_max . "_".$pm;
	my $new_gs=$ar . "/" . $n_max . "_".$gs;
	
	copy($pm, $new_pm);
	copy($gs, $new_gs);
	
	closedir AR;
	print '';

}

sub check_manifest {	# to add the gs-file, if necessary
	my ($gs)=@_;
	if(open M, "MANIFEST") {
		my @man=<M>;
		close M;
		
		copy('MANIFEST', 'MANIFEST.cp'); # precaution
		
		unless(grep /$gs/, @man) {
			open M, ">MANIFEST";
			print M @man;
			print M "\n".$gs."\n";
			close M;
		}
	}
}

sub check_of_sections {		# to ensure every needed section is there
	# these have to be found
	my %found;					# what has been found
# 	my @expected_sections = qw/ head bless var /;	# to be less strict
	
	my @expected_sections = qw/ head var /;		# to be less strict
	my $n_colons = 0;				# counting nmb. of :
							# to indicate #sections
	# to check each line
	my $x;	
	foreach $x (<I> ) {
		next unless( $x=~m/[^:]:[^:]/  );	# must be a section delimiter

		$n_colons += 1;
		foreach (@expected_sections) {
			$found{$_} += 1 if($x=~m/$_/);	# yield some statistics
		}
	}

	# to compare what is missing and what is present
	print "#: $n_colons\n";
	print %found, "\n";
	print "N: ", scalar @expected_sections, "\n";

	unless ($n_colons == @expected_sections) {
		print "Use only ";
		foreach (@expected_sections) {print "$_: ";}
		print " sections.\n";

	}