view release on metacpan or  search on metacpan

lib/Container/Builder.pm  view on Meta::CPAN

	field $os_version :param = 'bookworm';
	field @layers :reader(get_layers);
	field $original_dir = Cwd::getcwd();
	field $runas = 'root';
	field $work_dir = '/';
	field @entry :reader(get_entry);
	field @cmd :reader(get_cmd);
	field %env :reader(get_env);
	field %deb_packages;
	field @dirs :reader(get_dirs);
	field @users :reader(get_users);
	field @groups :reader(get_groups);
	field $packages; 

	# Podman will use the Container::Builder::Config digest as the identifier for your imported container. Users might want to have this ID.
	field $ctr_digest = undef;

	method _parse_packages(@fields) {
		if($enable_packages_cache && !-r $packages_file) { # Our cache file does not exist
			$debian_pkg_hostname =~ s/[^\w\-\.]//g; # a light scrubbing on the hostname... But we still assume the caller does the scrubbing!
			my $packagesgz = LWP::Simple::get("https://$debian_pkg_hostname/debian/dists/$os_version/main/binary-amd64/Packages.gz");
			IO::Uncompress::Gunzip::gunzip(\$packagesgz => $packages_file);
			$packages = DPKG::Packages::Parser->new('file' => $packages_file);
		} elsif($enable_packages_cache) { # Our cache file exists
			$packages = DPKG::Packages::Parser->new('file' => $packages_file);
		} elsif(!$enable_packages_cache) { # don't drop anything to disk
			$debian_pkg_hostname =~ s/[^\w\-\.]//g; # a light scrubbing on the hostname... But we still assume the caller does the scrubbing!
			my $packagesgz = LWP::Simple::get("https://$debian_pkg_hostname/debian/dists/$os_version/main/binary-amd64/Packages.gz");
			my $packages_raw;
			IO::Uncompress::Gunzip::gunzip(\$packagesgz => \$packages_raw);
			open(my $f, '<', \$packages_raw);
			$packages = DPKG::Packages::Parser->new(fh => $f);
		}
		$packages->parse(@fields);
	}

	method _get_deb_package($package_name) {
		if($cache_folder) {
			my $cache_folder_ws = $cache_folder . (substr($cache_folder, -1) eq '/' ? '' : '/'); # ws = with slash
			if(-d $cache_folder_ws && -r $cache_folder_ws . $package_name . '.deb') {
				local $/ = undef;
				open(my $deb, '<', $cache_folder_ws . $package_name . '.deb') or die "Cannot open $cache_folder_ws$package_name.deb\n";
				my $deb_content = <$deb>;
				close($deb);
				return $deb_content;
			}
		}

		$self->_parse_packages('Filename', 'Depends') if !$packages; # lazy load on first call
		my $pkg = $packages->get_package($package_name);
		return 0 if !$pkg;

		my $filepath = $pkg->{Filename};
		my ($filename) = $filepath =~ m/([^\/]+)$/;
		my $url = "https://debian.inf.tu-dresden.de/debian/" . $filepath;
		my $lwp = LWP::UserAgent->new();
		my $response = $lwp->get($url);
		if(!$response->is_success) { # Added because my base perl LWP didn't have the https package to support https...
			die "Call to Debian package repo failed: " . $response->status_line;
		}
		my $package_content = $response->decoded_content;
		die "unable to get package content with LWP::Simple" if !$package_content;
		return $package_content;
	}

	method add_deb_package($package_name) {
		return 0 if $deb_packages{$package_name};
		my $package_content = $self->_get_deb_package($package_name);
		return 0 if ! $package_content;

		if($cache_folder) {
			my $cache_folder_ws = $cache_folder . (substr($cache_folder, -1) eq '/' ? '' : '/'); # ws = with slash
			if(!-r $cache_folder_ws . $package_name . '.deb') {
				open(my $f, '>', $cache_folder_ws . $package_name . '.deb') or die "cannot open $cache_folder_ws$package_name.deb\n";
				print $f $package_content;
				close($f);
			}
		}

		# Before adding the package as a layer, get the dependencies and add those
		$deb_packages{$package_name} = 1;
		$self->_parse_packages('Filename', 'Depends') if !$packages; # lazy load on first call
		my $pkg = $packages->get_package($package_name);
		foreach(@{$pkg->{Depends}}) {
			if(ref eq 'ARRAY') {
				# TODO: there's no way we can make an intelligent decision here, we can check if any of these have already been added or not. If one of the options was already added, we can skip choosing; if none was already added, take the first one.
				$self->add_deb_package(${$_}[0]->{name});
			} elsif(ref eq 'HASH') {
				$self->add_deb_package($_->{name});
			}
		}

		push @layers, Container::Builder::Layer::DebianPackageFile->new(comment => $package_name, data => $package_content, compress => $compress_deb_tar);
	}

	# Create a layer that adds a package to the container
	method add_deb_package_from_file($filepath_deb) {
		die "Unable to read $filepath_deb\n" if !-r $filepath_deb;
		push @layers, Container::Builder::Layer::DebianPackageFile->new(comment => $filepath_deb, file => $filepath_deb, compress => $compress_deb_tar);
	}

	method extract_from_deb($package_name, $files_to_extract) {
		my $deb_archive = $self->_get_deb_package($package_name);
		if($deb_archive) {
			# Read the tar -> with our own class because Archive::Tar doesn't read from a string...
			my $deb = Container::Builder::Layer::DebianPackageFile->new(comment => $package_name, data => $deb_archive, compress => $compress_deb_tar);
			my $tar = $deb->generate_artifact();
			my $tar_builder = Container::Builder::Tar->new();
			my $result_tar = '';
			foreach(@$files_to_extract) {
				my $tar_file = '';
				if($_ =~ /\*$/) {
					$tar_file = $tar_builder->extract_wildcard_files($tar, $_);
				} else {
					$tar_file = $tar_builder->extract_file($tar, $_);
				}
				$result_tar .= $tar_file;
			}
			$result_tar .= "\x00" x 1024; # two empty blocks
			push @layers, Container::Builder::Layer::Tar->new(comment => "custom $package_name", data => $result_tar);
		} else {