view release on metacpan or  search on metacpan

Agent.pm  view on Meta::CPAN

##
## archived
##

sub archived {
	my $self = shift;

	-r $self->{rcsfile} ? 1 : 0;
}


##
## parse
##
## parses the RCS archive file.  This is an internal-only function.  Please ignore it.
##
## returns:     1 if the file already has a readable and parsable RCS archive file
##              undef otherwise, putting flag in error buffer
##

sub parse {
	my $self = shift;
	my %args = @_;
	my %branches;

	$self->{err} = "";

	# only parse file if not parsed previously and rcs file has not been modified
	if ($self->{parsed}) {
		my $mtime = $self->{mtime};
		return 1 if ($mtime == $self->timestamp);
	}

	if (!$self->archived) {
		$self->{err} = "RCS archive file not found";
		return undef;
	} 

	# This is to prevent recursion
	if (defined ($self->{parsing})) {
		return 1;
	}
	$self->{parsing} = 1;

	# First, we need to delete a whole bunch of stuff if it's already
	# defined from previous parsing attempts.
	foreach my $tag (qw (access revisions head symbols strict)) {
		delete $self->{$tag} if defined ($self->{$tag});
	}

	unless (open (INPUT, $self->{rcsfile})) {
		$self->{err} = "couldn't open $self->{rcsfile}: $!";
		return undef;
	}

	# The preamble contains information about the archive.  We slurp it in as a single
	# paragraph

	my $oldseparator = $/;
	$/ = "";

	my $data = <INPUT>;
	$data =~ s/[\n\r\s]+/ /g;
	my @tokens = split (/\s*;\s*/, $data);

	$self->{strict} = 0;

	# For the moment, we only parse head, locks, symbols and strict.
	foreach my $token (@tokens) {
		if ($token =~ /^access/) {
			my @access = split (/ /, $token); shift @access;
                        $self->{access} = \@access if @access;
			next;
		}

		if ($token =~ /^head\s+([\d\.]+)/) {
			$self->{head} = $1;
			next;
		}

		if ($token =~ /^strict/) {
			$self->{strict} = 1;
			next;
		}

		if ($token =~ /^symbols/) {
			my @symtokens = split (/ /, $token); shift @symtokens;
			foreach my $tag (@symtokens) {
				next unless ($tag =~ /(.*):(.*)/);
				$self->{symbols}->{$1} = $2;
			}
			next;
		}

		if ($token =~ /^locks/) {
			my @symtokens = split (/ /, $token); shift @symtokens;
			foreach my $tag (@symtokens) {
				next unless ($tag =~ /(.*):(.*)/);
				$self->{revisions}->{$2}->{locker} = $1;
			}
			next;
		}
	}

	# deal with the individual revision entry
	while ($data = <INPUT>) {
		my ($nextrev);
		$data =~ s/[\n\r\s]+/ /g;
		next unless ($data =~ /([\d\.]+)\s+(.*)/);
		my $revision = $1; $data = $2;

		delete $branches{$revision} if ($branches{$revision});

		@tokens = split (/\s*;\s*/, $data);

		foreach my $token (@tokens) {
			if ($token =~ /^next\s+([\d\.]+)/) {
				my ($up, $down) = qw (parent child);
				$nextrev = $1;