postgres/src/tools/msvc/Project.pm

# Copyright (c) 2021-2023, PostgreSQL Global Development Group

package Project;

#
# Package that encapsulates a Visual C++ project file generation
#
# src/tools/msvc/Project.pm
#
use Carp;
use strict;
use warnings;
use File::Basename;

sub _new
{
	my ($classname, $name, $type, $solution) = @_;
	my $good_types = {
		lib => 1,
		exe => 1,
		dll => 1,
	};
	confess("Bad project type: $type\n") unless exists $good_types->{$type};
	my $self = {
		name => $name,
		type => $type,
		guid => $^O eq "MSWin32" ? Win32::GuidGen() : 'FAKE',
		files => {},
		references => [],
		libraries => [],
		suffixlib => [],
		includes => [],
		prefixincludes => '',
		defines => ';',
		solution => $solution,
		disablewarnings => '4018;4244;4273;4101;4102;4090;4267',
		disablelinkerwarnings => '',
		platform => $solution->{platform},
	};

	bless($self, $classname);
	return $self;
}

sub AddFile
{
	my ($self, $filename) = @_;

	$self->FindAndAddAdditionalFiles($filename);
	$self->{files}->{$filename} = 1;
	return;
}

sub AddDependantFiles
{
	my ($self, $filename) = @_;

	$self->FindAndAddAdditionalFiles($filename);
	return;
}

sub AddFiles
{
	my $self = shift;
	my $dir = shift;

	while (my $f = shift)
	{
		$self->AddFile($dir . "/" . $f, 1);
	}
	return;
}

# Handle Makefile rules by searching for other files which exist with the same
# name but a different file extension and add those files too.
sub FindAndAddAdditionalFiles
{
	my $self = shift;
	my $fname = shift;
	$fname =~ /(.*)(\.[^.]+)$/;
	my $filenoext = $1;
	my $fileext = $2;

	# For .c files, check if either a .l or .y file of the same name
	# exists and add that too.
	if ($fileext eq ".c")
	{
		my $file = $filenoext . ".l";
		if (-e $file)
		{
			$self->AddFile($file);
		}

		$file = $filenoext . ".y";
		if (-e $file)
		{
			$self->AddFile($file);
		}
	}
}

sub ReplaceFile
{
	my ($self, $filename, $newname) = @_;
	my $re = "\\/$filename\$";

	foreach my $file (keys %{ $self->{files} })
	{

		# Match complete filename
		if ($filename =~ m!/!)
		{
			if ($file eq $filename)
			{
				delete $self->{files}{$file};
				$self->AddFile($newname);
				return;
			}
		}
		elsif ($file =~ m/($re)/)
		{
			delete $self->{files}{$file};
			$self->AddFile("$newname/$filename");
			return;
		}
	}
	confess("Could not find file $filename to replace\n");
}

sub RemoveFile
{
	my ($self, $filename) = @_;
	my $orig = scalar keys %{ $self->{files} };
	delete $self->{files}->{$filename};
	if ($orig > scalar keys %{ $self->{files} })
	{
		return;
	}
	confess("Could not find file $filename to remove\n");
}

sub RelocateFiles
{
	my ($self, $targetdir, $proc) = @_;
	foreach my $f (keys %{ $self->{files} })
	{
		my $r = &$proc($f);
		if ($r)
		{
			$self->RemoveFile($f);
			$self->AddFile($targetdir . '/' . basename($f));
		}
	}
	return;
}

sub AddReference
{
	my $self = shift;

	while (my $ref = shift)
	{
		if (!grep { $_ eq $ref } @{ $self->{references} })
		{
			push @{ $self->{references} }, $ref;
		}
		$self->AddLibrary(
			"__CFGNAME__/" . $ref->{name} . "/" . $ref->{name} . ".lib");
	}
	return;
}

sub AddLibrary
{
	my ($self, $lib, $dbgsuffix) = @_;

	# quote lib name if it has spaces and isn't already quoted
	if ($lib =~ m/\s/ && $lib !~ m/^[&]quot;/)
	{
		$lib = '"' . $lib . """;
	}

	if (!grep { $_ eq $lib } @{ $self->{libraries} })
	{
		push @{ $self->{libraries} }, $lib;
	}

	if ($dbgsuffix)
	{
		push @{ $self->{suffixlib} }, $lib;
	}
	return;
}

sub AddIncludeDir
{
	my ($self, $incstr) = @_;

	foreach my $inc (split(/;/, $incstr))
	{
		if (!grep { $_ eq $inc } @{ $self->{includes} })
		{
			push @{ $self->{includes} }, $inc;
		}
	}
	return;
}

sub AddPrefixInclude
{
	my ($self, $inc) = @_;

	$self->{prefixincludes} = $inc . ';' . $self->{prefixincludes};
	return;
}

sub AddDefine
{
	my ($self, $def) = @_;

	$def =~ s/"/""/g;
	$self->{defines} .= $def . ';';
	return;
}

sub FullExportDLL
{
	my ($self, $libname) = @_;

	$self->{builddef} = 1;
	$self->{def} = "./__CFGNAME__/$self->{name}/$self->{name}.def";
	$self->{implib} = "__CFGNAME__/$self->{name}/$libname";
	return;
}

sub UseDef
{
	my ($self, $def) = @_;

	$self->{def} = $def;
	return;
}

sub AddDir
{
	my ($self, $reldir) = @_;
	my $mf = read_makefile($reldir);

	$mf =~ s{\\\r?\n}{}g;
	if ($mf =~ m{^(?:SUB)?DIRS[^=]*=\s*(.*)$}mg)
	{
		foreach my $subdir (split /\s+/, $1)
		{
			next
			  if $subdir eq "\$(top_builddir)/src/timezone"
			  ;    #special case for non-standard include
			next
			  if $reldir . "/" . $subdir eq "src/backend/port/darwin";

			$self->AddDir($reldir . "/" . $subdir);
		}
	}
	while ($mf =~ m{^(?:EXTRA_)?OBJS[^=]*=\s*(.*)$}m)
	{
		my $s = $1;
		my $filter_re = qr{\$\(filter ([^,]+),\s+\$\(([^\)]+)\)\)};
		while ($s =~ /$filter_re/)
		{

			# Process $(filter a b c, $(VAR)) expressions
			my $list = $1;
			my $filter = $2;
			$list =~ s/\.o/\.c/g;
			my @pieces = split /\s+/, $list;
			my $matches = "";
			foreach my $p (@pieces)
			{

				if ($filter eq "LIBOBJS")
				{
					no warnings qw(once);
					if (grep(/$p/, @main::pgportfiles) == 1)
					{
						$p =~ s/\.c/\.o/;
						$matches .= $p . " ";
					}
				}
				else
				{
					confess "Unknown filter $filter\n";
				}
			}
			$s =~ s/$filter_re/$matches/;
		}
		foreach my $f (split /\s+/, $s)
		{
			next if $f =~ /^\s*$/;
			next if $f eq "\\";
			next if $f =~ /\/SUBSYS.o$/;
			$f =~ s/,$//
			  ;    # Remove trailing comma that can show up from filter stuff
			next unless $f =~ /.*\.o$/;
			$f =~ s/\.o$/\.c/;
			if ($f =~ /^\$\(top_builddir\)\/(.*)/)
			{
				$f = $1;
				$self->AddFile($f);
			}
			else
			{
				$self->AddFile("$reldir/$f");
			}
		}
		$mf =~ s{OBJS[^=]*=\s*(.*)$}{}m;
	}

	# Match rules that pull in source files from different directories, eg
	# pgstrcasecmp.c rint.c snprintf.c: % : $(top_srcdir)/src/port/%
	my $replace_re =
	  qr{^([^:\n\$]+\.c)\s*:\s*(?:%\s*: )?\$(\([^\)]+\))\/(.*)\/[^\/]+\n}m;
	while ($mf =~ m{$replace_re}m)
	{
		my $match = $1;
		my $top = $2;
		my $target = $3;
		my @pieces = split /\s+/, $match;
		foreach my $fn (@pieces)
		{
			if ($top eq "(top_srcdir)")
			{
				eval { $self->ReplaceFile($fn, $target) };
			}
			elsif ($top eq "(backend_src)")
			{
				eval { $self->ReplaceFile($fn, "src/backend/$target") };
			}
			else
			{
				confess "Bad replacement top: $top, on line $_\n";
			}
		}
		$mf =~ s{$replace_re}{}m;
	}

	$self->AddDirResourceFile($reldir);
	return;
}

# If the directory's Makefile bears a description string, add a resource file.
sub AddDirResourceFile
{
	my ($self, $reldir) = @_;
	my $mf = read_makefile($reldir);

	if ($mf =~ /^PGFILEDESC\s*=\s*\"([^\"]+)\"/m)
	{
		my $desc = $1;
		my $ico;
		if ($mf =~ /^PGAPPICON\s*=\s*(.*)$/m) { $ico = $1; }
		$self->AddResourceFile($reldir, $desc, $ico);
	}
	return;
}

sub AddResourceFile
{
	my ($self, $dir, $desc, $ico) = @_;

	if (Solution::IsNewer("$dir/win32ver.rc", 'src/port/win32ver.rc'))
	{
		print "Generating win32ver.rc for $dir\n";
		open(my $i, '<', 'src/port/win32ver.rc')
		  || confess "Could not open win32ver.rc";
		open(my $o, '>', "$dir/win32ver.rc")
		  || confess "Could not write win32ver.rc";
		my $icostr = $ico ? "IDI_ICON ICON \"src/port/$ico.ico\"" : "";
		while (<$i>)
		{
			s/FILEDESC/"$desc"/gm;
			s/_ICO_/$icostr/gm;
			if ($self->{type} eq "dll")
			{
				s/VFT_APP/VFT_DLL/gm;
				my $name = $self->{name};
				s/_INTERNAL_NAME_/"$name"/;
				s/_ORIGINAL_NAME_/"$name.dll"/;
			}
			else
			{
				/_INTERNAL_NAME_/ && next;
				/_ORIGINAL_NAME_/ && next;
			}
			print $o $_;
		}
		close($o);
		close($i);
	}
	$self->AddFile("$dir/win32ver.rc");
	return;
}

sub DisableLinkerWarnings
{
	my ($self, $warnings) = @_;

	$self->{disablelinkerwarnings} .= ','
	  unless ($self->{disablelinkerwarnings} eq '');
	$self->{disablelinkerwarnings} .= $warnings;
	return;
}

sub Save
{
	my ($self) = @_;

	# Warning 4197 is about double exporting, disable this per
	# http://connect.microsoft.com/VisualStudio/feedback/ViewFeedback.aspx?FeedbackID=99193
	$self->DisableLinkerWarnings('4197') if ($self->{platform} eq 'x64');

	# Dump the project
	open(my $f, '>', "$self->{name}$self->{filenameExtension}")
	  || croak(
		"Could not write to $self->{name}$self->{filenameExtension}\n");
	$self->WriteHeader($f);
	$self->WriteFiles($f);
	$self->Footer($f);
	close($f);
	return;
}

sub GetAdditionalLinkerDependencies
{
	my ($self, $cfgname, $separator) = @_;
	my $libcfg = (uc $cfgname eq "RELEASE") ? "MD" : "MDd";
	my $libs = '';
	foreach my $lib (@{ $self->{libraries} })
	{
		my $xlib = $lib;
		foreach my $slib (@{ $self->{suffixlib} })
		{
			if ($slib eq $lib)
			{
				$xlib =~ s/\.lib$/$libcfg.lib/;
				last;
			}
		}
		$libs .= $xlib . $separator;
	}
	$libs =~ s/.$//;
	$libs =~ s/__CFGNAME__/$cfgname/g;
	return $libs;
}

# Utility function that loads a complete file
sub read_file
{
	my $filename = shift;
	my $F;
	local $/ = undef;
	open($F, '<', $filename) || croak "Could not open file $filename\n";
	my $txt = <$F>;
	close($F);

	return $txt;
}

sub read_makefile
{
	my $reldir = shift;
	my $F;
	local $/ = undef;
	open($F, '<', "$reldir/GNUmakefile")
	  || open($F, '<', "$reldir/Makefile")
	  || confess "Could not open $reldir/Makefile\n";
	my $txt = <$F>;
	close($F);

	return $txt;
}

1;