summaryrefslogtreecommitdiffstats
path: root/lib/Lintian
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Lintian')
-rw-r--r--lib/Lintian/Archive.pm179
-rw-r--r--lib/Lintian/Changelog.pm380
-rw-r--r--lib/Lintian/Changelog/Entry.pm184
-rw-r--r--lib/Lintian/Changelog/Version.pm250
-rw-r--r--lib/Lintian/Check.pm232
-rw-r--r--lib/Lintian/Check/Apache2.pm337
-rw-r--r--lib/Lintian/Check/ApplicationNotLibrary.pm141
-rw-r--r--lib/Lintian/Check/AppstreamMetadata.pm269
-rw-r--r--lib/Lintian/Check/Apt.pm69
-rw-r--r--lib/Lintian/Check/Archive/File/Name/Length.pm93
-rw-r--r--lib/Lintian/Check/Archive/Liberty/Mismatch.pm138
-rw-r--r--lib/Lintian/Check/Archive/NonFree/Autobuild.pm70
-rw-r--r--lib/Lintian/Check/Binaries.pm73
-rw-r--r--lib/Lintian/Check/Binaries/Architecture.pm60
-rw-r--r--lib/Lintian/Check/Binaries/Architecture/Other.pm141
-rw-r--r--lib/Lintian/Check/Binaries/Corrupted.pm93
-rw-r--r--lib/Lintian/Check/Binaries/DebugSymbols.pm72
-rw-r--r--lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm86
-rw-r--r--lib/Lintian/Check/Binaries/Hardening.pm183
-rw-r--r--lib/Lintian/Check/Binaries/LargeFileSupport.pm108
-rw-r--r--lib/Lintian/Check/Binaries/Location.pm138
-rw-r--r--lib/Lintian/Check/Binaries/Obsolete/Crypt.pm90
-rw-r--r--lib/Lintian/Check/Binaries/Prerequisites.pm214
-rw-r--r--lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm107
-rw-r--r--lib/Lintian/Check/Binaries/Prerequisites/Perl.pm81
-rw-r--r--lib/Lintian/Check/Binaries/Prerequisites/Php.pm80
-rw-r--r--lib/Lintian/Check/Binaries/Profiling.pm73
-rw-r--r--lib/Lintian/Check/Binaries/Rpath.pm145
-rw-r--r--lib/Lintian/Check/Binaries/Spelling.pm86
-rw-r--r--lib/Lintian/Check/Binaries/Static.pm100
-rw-r--r--lib/Lintian/Check/BuildSystems/Automake.pm54
-rw-r--r--lib/Lintian/Check/BuildSystems/Autotools.pm88
-rw-r--r--lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm99
-rw-r--r--lib/Lintian/Check/BuildSystems/Cmake.pm73
-rw-r--r--lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm80
-rw-r--r--lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm94
-rw-r--r--lib/Lintian/Check/BuildSystems/Waf.pm87
-rw-r--r--lib/Lintian/Check/ChangesFile.pm121
-rw-r--r--lib/Lintian/Check/Conffiles.pm136
-rw-r--r--lib/Lintian/Check/ContinuousIntegration/Salsa.pm103
-rw-r--r--lib/Lintian/Check/ControlFiles.pm132
-rw-r--r--lib/Lintian/Check/Cron.pm67
-rw-r--r--lib/Lintian/Check/Cruft.pm836
-rw-r--r--lib/Lintian/Check/DebFormat.pm227
-rw-r--r--lib/Lintian/Check/Debhelper.pm1088
-rw-r--r--lib/Lintian/Check/Debhelper/Temporary.pm55
-rw-r--r--lib/Lintian/Check/Debian/Changelog.pm970
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Adopted.pm98
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm63
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm110
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm66
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm114
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm83
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Empty.pm84
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Misplaced.pm67
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Redundant.pm68
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Relation.pm180
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm99
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Section.pm52
-rw-r--r--lib/Lintian/Check/Debian/Control/Field/Spacing.pm78
-rw-r--r--lib/Lintian/Check/Debian/Control/Link.pm57
-rw-r--r--lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm74
-rw-r--r--lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm145
-rw-r--r--lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm99
-rw-r--r--lib/Lintian/Check/Debian/Copyright.pm586
-rw-r--r--lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm105
-rw-r--r--lib/Lintian/Check/Debian/Copyright/Dep5.pm968
-rw-r--r--lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm109
-rw-r--r--lib/Lintian/Check/Debian/Debconf.pm794
-rw-r--r--lib/Lintian/Check/Debian/DesktopEntries.pm58
-rw-r--r--lib/Lintian/Check/Debian/Filenames.pm78
-rw-r--r--lib/Lintian/Check/Debian/Files.pm60
-rw-r--r--lib/Lintian/Check/Debian/LineSeparators.pm62
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides.pm64
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Comments.pm88
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm75
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm52
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm65
-rw-r--r--lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm80
-rw-r--r--lib/Lintian/Check/Debian/Maintscript.pm73
-rw-r--r--lib/Lintian/Check/Debian/ManualPages.pm67
-rw-r--r--lib/Lintian/Check/Debian/NotInstalled.pm74
-rw-r--r--lib/Lintian/Check/Debian/Patches.pm104
-rw-r--r--lib/Lintian/Check/Debian/Patches/Count.pm54
-rw-r--r--lib/Lintian/Check/Debian/Patches/Dep3.pm105
-rw-r--r--lib/Lintian/Check/Debian/Patches/Dpatch.pm150
-rw-r--r--lib/Lintian/Check/Debian/Patches/Quilt.pm290
-rw-r--r--lib/Lintian/Check/Debian/PoDebconf.pm391
-rw-r--r--lib/Lintian/Check/Debian/Readme.pm176
-rw-r--r--lib/Lintian/Check/Debian/Rules.pm671
-rw-r--r--lib/Lintian/Check/Debian/Rules/DhSequencer.pm65
-rw-r--r--lib/Lintian/Check/Debian/Shlibs.pm656
-rw-r--r--lib/Lintian/Check/Debian/Source/IncludeBinaries.pm77
-rw-r--r--lib/Lintian/Check/Debian/SourceDir.pm170
-rw-r--r--lib/Lintian/Check/Debian/Substvars.pm55
-rw-r--r--lib/Lintian/Check/Debian/Symbols.pm83
-rw-r--r--lib/Lintian/Check/Debian/TrailingWhitespace.pm105
-rw-r--r--lib/Lintian/Check/Debian/Upstream/Metadata.pm191
-rw-r--r--lib/Lintian/Check/Debian/Upstream/SigningKey.pm173
-rw-r--r--lib/Lintian/Check/Debian/Variables.pm60
-rw-r--r--lib/Lintian/Check/Debian/VersionSubstvars.pm206
-rw-r--r--lib/Lintian/Check/Debian/Watch.pm379
-rw-r--r--lib/Lintian/Check/Debian/Watch/Standard.pm98
-rw-r--r--lib/Lintian/Check/Debug/Automatic.pm63
-rw-r--r--lib/Lintian/Check/Debug/Obsolete.pm70
-rw-r--r--lib/Lintian/Check/Desktop/Dbus.pm189
-rw-r--r--lib/Lintian/Check/Desktop/Gnome.pm49
-rw-r--r--lib/Lintian/Check/Desktop/Gnome/Gir.pm166
-rw-r--r--lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm65
-rw-r--r--lib/Lintian/Check/Desktop/Icons.pm69
-rw-r--r--lib/Lintian/Check/Desktop/X11.pm94
-rw-r--r--lib/Lintian/Check/Desktop/X11/Font/Update.pm159
-rw-r--r--lib/Lintian/Check/DhMake.pm83
-rw-r--r--lib/Lintian/Check/DhMake/Template.pm52
-rw-r--r--lib/Lintian/Check/Documentation.pm246
-rw-r--r--lib/Lintian/Check/Documentation/Devhelp.pm87
-rw-r--r--lib/Lintian/Check/Documentation/Devhelp/Standard.pm47
-rw-r--r--lib/Lintian/Check/Documentation/Doxygen.pm75
-rw-r--r--lib/Lintian/Check/Documentation/Examples.pm48
-rw-r--r--lib/Lintian/Check/Documentation/Manual.pm663
-rw-r--r--lib/Lintian/Check/Documentation/Texinfo.pm195
-rw-r--r--lib/Lintian/Check/Emacs.pm58
-rw-r--r--lib/Lintian/Check/Emacs/Elpa.pm51
-rw-r--r--lib/Lintian/Check/Examples.pm82
-rw-r--r--lib/Lintian/Check/Executable.pm59
-rw-r--r--lib/Lintian/Check/Fields/Architecture.pm132
-rw-r--r--lib/Lintian/Check/Fields/Bugs.pm62
-rw-r--r--lib/Lintian/Check/Fields/BuiltUsing.pm72
-rw-r--r--lib/Lintian/Check/Fields/ChangedBy.pm66
-rw-r--r--lib/Lintian/Check/Fields/Checksums.pm53
-rw-r--r--lib/Lintian/Check/Fields/Deb822.pm89
-rw-r--r--lib/Lintian/Check/Fields/Derivatives.pm88
-rw-r--r--lib/Lintian/Check/Fields/Description.pm323
-rw-r--r--lib/Lintian/Check/Fields/Distribution.pm167
-rw-r--r--lib/Lintian/Check/Fields/DmUploadAllowed.pm60
-rw-r--r--lib/Lintian/Check/Fields/Empty.pm49
-rw-r--r--lib/Lintian/Check/Fields/Essential.pm79
-rw-r--r--lib/Lintian/Check/Fields/Format.pm78
-rw-r--r--lib/Lintian/Check/Fields/Homepage.pm101
-rw-r--r--lib/Lintian/Check/Fields/InstallerMenuItem.pm59
-rw-r--r--lib/Lintian/Check/Fields/Length.pm86
-rw-r--r--lib/Lintian/Check/Fields/MailAddress.pm150
-rw-r--r--lib/Lintian/Check/Fields/Maintainer.pm84
-rw-r--r--lib/Lintian/Check/Fields/Maintainer/Team.pm90
-rw-r--r--lib/Lintian/Check/Fields/MultiArch.pm138
-rw-r--r--lib/Lintian/Check/Fields/MultiLine.pm89
-rw-r--r--lib/Lintian/Check/Fields/Origin.pm57
-rw-r--r--lib/Lintian/Check/Fields/Package.pm61
-rw-r--r--lib/Lintian/Check/Fields/PackageRelations.pm794
-rw-r--r--lib/Lintian/Check/Fields/PackageType.pm58
-rw-r--r--lib/Lintian/Check/Fields/Priority.pm82
-rw-r--r--lib/Lintian/Check/Fields/Recommended.pm142
-rw-r--r--lib/Lintian/Check/Fields/Required.pm144
-rw-r--r--lib/Lintian/Check/Fields/Section.pm140
-rw-r--r--lib/Lintian/Check/Fields/Source.pm99
-rw-r--r--lib/Lintian/Check/Fields/StandardsVersion.pm164
-rw-r--r--lib/Lintian/Check/Fields/Style.pm84
-rw-r--r--lib/Lintian/Check/Fields/Subarchitecture.pm55
-rw-r--r--lib/Lintian/Check/Fields/TerminalControl.pm62
-rw-r--r--lib/Lintian/Check/Fields/Trimmed.pm52
-rw-r--r--lib/Lintian/Check/Fields/Unknown.pm86
-rw-r--r--lib/Lintian/Check/Fields/Uploaders.pm71
-rw-r--r--lib/Lintian/Check/Fields/Urgency.pm60
-rw-r--r--lib/Lintian/Check/Fields/Vcs.pm378
-rw-r--r--lib/Lintian/Check/Fields/Version.pm100
-rw-r--r--lib/Lintian/Check/Fields/Version/Derivative.pm82
-rw-r--r--lib/Lintian/Check/Fields/Version/Repack/Count.pm65
-rw-r--r--lib/Lintian/Check/Fields/Version/Repack/Native.pm63
-rw-r--r--lib/Lintian/Check/Fields/Version/Repack/Period.pm60
-rw-r--r--lib/Lintian/Check/Fields/Version/Repack/Tilde.pm60
-rw-r--r--lib/Lintian/Check/Fields/Version/Repack/Typo.pm64
-rw-r--r--lib/Lintian/Check/Files/Architecture.pm105
-rw-r--r--lib/Lintian/Check/Files/Artifact.pm140
-rw-r--r--lib/Lintian/Check/Files/Banned.pm113
-rw-r--r--lib/Lintian/Check/Files/Banned/CompiledHelp.pm58
-rw-r--r--lib/Lintian/Check/Files/Banned/Lenna.pm109
-rw-r--r--lib/Lintian/Check/Files/Bugs.pm50
-rw-r--r--lib/Lintian/Check/Files/BuildPath.pm55
-rw-r--r--lib/Lintian/Check/Files/Compressed.pm80
-rw-r--r--lib/Lintian/Check/Files/Compressed/Bz2.pm57
-rw-r--r--lib/Lintian/Check/Files/Compressed/Gz.pm113
-rw-r--r--lib/Lintian/Check/Files/Compressed/Lz.pm77
-rw-r--r--lib/Lintian/Check/Files/Compressed/Lzma.pm57
-rw-r--r--lib/Lintian/Check/Files/Compressed/Lzo.pm57
-rw-r--r--lib/Lintian/Check/Files/Compressed/Xz.pm57
-rw-r--r--lib/Lintian/Check/Files/Compressed/Zip.pm62
-rw-r--r--lib/Lintian/Check/Files/ConfigScripts.pm108
-rw-r--r--lib/Lintian/Check/Files/Contents.pm150
-rw-r--r--lib/Lintian/Check/Files/Contents/LineLength.pm140
-rw-r--r--lib/Lintian/Check/Files/Date.pm66
-rw-r--r--lib/Lintian/Check/Files/Debug.pm55
-rw-r--r--lib/Lintian/Check/Files/DebugPackages.pm50
-rw-r--r--lib/Lintian/Check/Files/Desktop.pm57
-rw-r--r--lib/Lintian/Check/Files/Duplicates.pm88
-rw-r--r--lib/Lintian/Check/Files/EmptyDirectories.pm67
-rw-r--r--lib/Lintian/Check/Files/EmptyPackage.pm159
-rw-r--r--lib/Lintian/Check/Files/Encoding.pm125
-rw-r--r--lib/Lintian/Check/Files/Generated.pm83
-rw-r--r--lib/Lintian/Check/Files/HardLinks.pm57
-rw-r--r--lib/Lintian/Check/Files/Hierarchy/Links.pm83
-rw-r--r--lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm48
-rw-r--r--lib/Lintian/Check/Files/Hierarchy/PathSegments.pm57
-rw-r--r--lib/Lintian/Check/Files/Hierarchy/Standard.pm262
-rw-r--r--lib/Lintian/Check/Files/IeeeData.pm79
-rw-r--r--lib/Lintian/Check/Files/Includes.pm69
-rw-r--r--lib/Lintian/Check/Files/Init.pm79
-rw-r--r--lib/Lintian/Check/Files/LdSo.pm48
-rw-r--r--lib/Lintian/Check/Files/Licenses.pm112
-rw-r--r--lib/Lintian/Check/Files/Locales.pm204
-rw-r--r--lib/Lintian/Check/Files/Missing.pm50
-rw-r--r--lib/Lintian/Check/Files/MultiArch.pm111
-rw-r--r--lib/Lintian/Check/Files/Names.pm163
-rw-r--r--lib/Lintian/Check/Files/NonFree.pm142
-rw-r--r--lib/Lintian/Check/Files/ObsoletePaths.pm92
-rw-r--r--lib/Lintian/Check/Files/Openpgp.pm51
-rw-r--r--lib/Lintian/Check/Files/Ownership.pm74
-rw-r--r--lib/Lintian/Check/Files/P11Kit.pm54
-rw-r--r--lib/Lintian/Check/Files/Pam.pm50
-rw-r--r--lib/Lintian/Check/Files/Permissions.pm249
-rw-r--r--lib/Lintian/Check/Files/Permissions/UsrLib.pm54
-rw-r--r--lib/Lintian/Check/Files/Pkgconfig.pm121
-rw-r--r--lib/Lintian/Check/Files/PrivacyBreach.pm420
-rw-r--r--lib/Lintian/Check/Files/Scripts.pm57
-rw-r--r--lib/Lintian/Check/Files/Sgml.pm48
-rw-r--r--lib/Lintian/Check/Files/SourceMissing.pm286
-rw-r--r--lib/Lintian/Check/Files/Special.pm50
-rw-r--r--lib/Lintian/Check/Files/SymbolicLinks.pm229
-rw-r--r--lib/Lintian/Check/Files/SymbolicLinks/Broken.pm119
-rw-r--r--lib/Lintian/Check/Files/Unicode/Trojan.pm134
-rw-r--r--lib/Lintian/Check/Files/Unwanted.pm55
-rw-r--r--lib/Lintian/Check/Files/UsrMerge.pm53
-rw-r--r--lib/Lintian/Check/Files/Vcs.pm113
-rw-r--r--lib/Lintian/Check/Fonts.pm92
-rw-r--r--lib/Lintian/Check/Fonts/Opentype.pm95
-rw-r--r--lib/Lintian/Check/Fonts/Postscript/Type1.pm130
-rw-r--r--lib/Lintian/Check/Fonts/Truetype.pm95
-rw-r--r--lib/Lintian/Check/ForeignOperatingSystems.pm63
-rw-r--r--lib/Lintian/Check/Games.pm90
-rw-r--r--lib/Lintian/Check/GroupChecks.pm282
-rw-r--r--lib/Lintian/Check/HugeUsrShare.pm98
-rw-r--r--lib/Lintian/Check/Images.pm49
-rw-r--r--lib/Lintian/Check/Images/Filenames.pm126
-rw-r--r--lib/Lintian/Check/Images/Thumbnails.pm56
-rw-r--r--lib/Lintian/Check/Includes/ConfigH.pm56
-rw-r--r--lib/Lintian/Check/InitD.pm733
-rw-r--r--lib/Lintian/Check/InitD/MaintainerScript.pm147
-rw-r--r--lib/Lintian/Check/Languages/Fortran/Gfortran.pm94
-rw-r--r--lib/Lintian/Check/Languages/Golang/BuiltUsing.pm68
-rw-r--r--lib/Lintian/Check/Languages/Golang/ImportPath.pm56
-rw-r--r--lib/Lintian/Check/Languages/Java.pm315
-rw-r--r--lib/Lintian/Check/Languages/Java/Bytecode.pm58
-rw-r--r--lib/Lintian/Check/Languages/Javascript/Embedded.pm149
-rw-r--r--lib/Lintian/Check/Languages/Javascript/Nodejs.pm262
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm85
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm63
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm58
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm126
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm105
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm56
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm59
-rw-r--r--lib/Lintian/Check/Languages/Ocaml/Meta.pm67
-rw-r--r--lib/Lintian/Check/Languages/Perl.pm125
-rw-r--r--lib/Lintian/Check/Languages/Perl/Core/Provides.pm83
-rw-r--r--lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm124
-rw-r--r--lib/Lintian/Check/Languages/Perl/Perl5.pm61
-rw-r--r--lib/Lintian/Check/Languages/Perl/Yapp.pm55
-rw-r--r--lib/Lintian/Check/Languages/Php.pm53
-rw-r--r--lib/Lintian/Check/Languages/Php/Composer.pm93
-rw-r--r--lib/Lintian/Check/Languages/Php/Embedded.pm92
-rw-r--r--lib/Lintian/Check/Languages/Php/Pear.pm242
-rw-r--r--lib/Lintian/Check/Languages/Php/Pear/Embedded.pm92
-rw-r--r--lib/Lintian/Check/Languages/Python.pm516
-rw-r--r--lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm88
-rw-r--r--lib/Lintian/Check/Languages/Python/DistOverrides.pm80
-rw-r--r--lib/Lintian/Check/Languages/Python/Distutils.pm77
-rw-r--r--lib/Lintian/Check/Languages/Python/Feedparser.pm54
-rw-r--r--lib/Lintian/Check/Languages/Python/Homepage.pm59
-rw-r--r--lib/Lintian/Check/Languages/Python/Obsolete.pm63
-rw-r--r--lib/Lintian/Check/Languages/Python/Scripts.pm54
-rw-r--r--lib/Lintian/Check/Languages/R.pm74
-rw-r--r--lib/Lintian/Check/Languages/R/Architecture.pm69
-rw-r--r--lib/Lintian/Check/Languages/R/SiteLibrary.pm71
-rw-r--r--lib/Lintian/Check/Languages/Ruby.pm72
-rw-r--r--lib/Lintian/Check/Languages/Rust.pm69
-rw-r--r--lib/Lintian/Check/Libraries/DebugSymbols.pm59
-rw-r--r--lib/Lintian/Check/Libraries/Embedded.pm124
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Exit.pm72
-rw-r--r--lib/Lintian/Check/Libraries/Shared/FilePermissions.pm72
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Links.pm167
-rw-r--r--lib/Lintian/Check/Libraries/Shared/MultiArch.pm79
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Obsolete.pm56
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Relocation.pm58
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Soname.pm123
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm73
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Stack.pm69
-rw-r--r--lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm131
-rw-r--r--lib/Lintian/Check/Libraries/Static.pm121
-rw-r--r--lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm70
-rw-r--r--lib/Lintian/Check/Libraries/Static/Name.pm61
-rw-r--r--lib/Lintian/Check/Libraries/Static/NoCode.pm95
-rw-r--r--lib/Lintian/Check/Linda.pm47
-rw-r--r--lib/Lintian/Check/Lintian.pm38
-rw-r--r--lib/Lintian/Check/Mailcap.pm108
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Adduser.pm96
-rw-r--r--lib/Lintian/Check/MaintainerScripts/AncientVersion.pm180
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Diversion.pm369
-rw-r--r--lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm148
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Empty.pm144
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Generated.pm85
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm183
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Killall.pm131
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Ldconfig.pm60
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Mknod.pm131
-rw-r--r--lib/Lintian/Check/MaintainerScripts/Systemctl.pm76
-rw-r--r--lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm144
-rw-r--r--lib/Lintian/Check/Md5sums.pm133
-rw-r--r--lib/Lintian/Check/MenuFormat.pm907
-rw-r--r--lib/Lintian/Check/Menus.pm818
-rw-r--r--lib/Lintian/Check/Mimeinfo.pm61
-rw-r--r--lib/Lintian/Check/Modprobe.pm61
-rw-r--r--lib/Lintian/Check/Nmu.pm193
-rw-r--r--lib/Lintian/Check/ObsoleteSites.pm96
-rw-r--r--lib/Lintian/Check/Origtar.pm55
-rw-r--r--lib/Lintian/Check/Pe.pm113
-rw-r--r--lib/Lintian/Check/Script/Deprecated/Chown.pm96
-rw-r--r--lib/Lintian/Check/Script/Syntax.pm224
-rw-r--r--lib/Lintian/Check/Scripts.pm1070
-rw-r--r--lib/Lintian/Check/Shell/Bash/Completion.pm54
-rw-r--r--lib/Lintian/Check/Shell/Csh.pm89
-rw-r--r--lib/Lintian/Check/Shell/NonPosix/BashCentric.pm348
-rw-r--r--lib/Lintian/Check/Substvars/Libc.pm86
-rw-r--r--lib/Lintian/Check/Substvars/Misc/PreDepends.pm64
-rw-r--r--lib/Lintian/Check/Systemd.pm530
-rw-r--r--lib/Lintian/Check/Systemd/Native/Prerequisites.pm146
-rw-r--r--lib/Lintian/Check/Systemd/Tmpfiles.pm57
-rw-r--r--lib/Lintian/Check/Team/PkgJs/Deprecated.pm76
-rw-r--r--lib/Lintian/Check/Team/PkgJs/Testsuite.pm73
-rw-r--r--lib/Lintian/Check/Team/PkgJs/Vcs.pm78
-rw-r--r--lib/Lintian/Check/Team/PkgPerl/Testsuite.pm78
-rw-r--r--lib/Lintian/Check/Team/PkgPerl/Vcs.pm77
-rw-r--r--lib/Lintian/Check/Team/PkgPerl/XsAbi.pm95
-rw-r--r--lib/Lintian/Check/Template/DhMake/Control/Vcs.pm77
-rw-r--r--lib/Lintian/Check/Testsuite.pm352
-rw-r--r--lib/Lintian/Check/Triggers.pm145
-rw-r--r--lib/Lintian/Check/Udev.pm172
-rw-r--r--lib/Lintian/Check/Unpack.pm67
-rw-r--r--lib/Lintian/Check/UpstreamSignature.pm126
-rw-r--r--lib/Lintian/Check/Usrmerge.pm66
-rw-r--r--lib/Lintian/Check/Vim.pm53
-rw-r--r--lib/Lintian/Check/Vim/Addons.pm48
-rw-r--r--lib/Lintian/Conffiles.pm162
-rw-r--r--lib/Lintian/Conffiles/Entry.pm72
-rw-r--r--lib/Lintian/Data.pm354
-rw-r--r--lib/Lintian/Data/Architectures.pm441
-rw-r--r--lib/Lintian/Data/Archive/AutoRejection.pm154
-rw-r--r--lib/Lintian/Data/Archive/Sections.pm133
-rw-r--r--lib/Lintian/Data/Authorities.pm330
-rw-r--r--lib/Lintian/Data/Authority/DebconfSpecification.pm328
-rw-r--r--lib/Lintian/Data/Authority/DebianPolicy.pm321
-rw-r--r--lib/Lintian/Data/Authority/DeveloperReference.pm319
-rw-r--r--lib/Lintian/Data/Authority/DocBaseManual.pm431
-rw-r--r--lib/Lintian/Data/Authority/FilesystemHierarchy.pm333
-rw-r--r--lib/Lintian/Data/Authority/JavaPolicy.pm290
-rw-r--r--lib/Lintian/Data/Authority/LintianManual.pm324
-rw-r--r--lib/Lintian/Data/Authority/MenuManual.pm316
-rw-r--r--lib/Lintian/Data/Authority/MenuPolicy.pm316
-rw-r--r--lib/Lintian/Data/Authority/NewMaintainer.pm290
-rw-r--r--lib/Lintian/Data/Authority/PerlPolicy.pm316
-rw-r--r--lib/Lintian/Data/Authority/PythonPolicy.pm317
-rw-r--r--lib/Lintian/Data/Authority/VimPolicy.pm459
-rw-r--r--lib/Lintian/Data/Buildflags/Hardening.pm154
-rw-r--r--lib/Lintian/Data/Debhelper/Addons.pm215
-rw-r--r--lib/Lintian/Data/Debhelper/Commands.pm306
-rw-r--r--lib/Lintian/Data/Debhelper/Levels.pm89
-rw-r--r--lib/Lintian/Data/Fonts.pm216
-rw-r--r--lib/Lintian/Data/InitD/VirtualFacilities.pm256
-rw-r--r--lib/Lintian/Data/JoinedLines.pm369
-rw-r--r--lib/Lintian/Data/Policy/Releases.pm274
-rw-r--r--lib/Lintian/Data/PreambledJSON.pm164
-rw-r--r--lib/Lintian/Data/Provides/MailTransportAgent.pm193
-rw-r--r--lib/Lintian/Data/Stylesheet.pm139
-rw-r--r--lib/Lintian/Data/Traditional.pm73
-rw-r--r--lib/Lintian/Deb822.pm692
-rw-r--r--lib/Lintian/Deb822/Constants.pm87
-rw-r--r--lib/Lintian/Deb822/Section.pm373
-rw-r--r--lib/Lintian/Debian/Control.pm198
-rw-r--r--lib/Lintian/Elf/Section.pm156
-rw-r--r--lib/Lintian/Elf/Symbol.pm90
-rw-r--r--lib/Lintian/Group.pm794
-rw-r--r--lib/Lintian/Hint.pm88
-rw-r--r--lib/Lintian/Hint/Annotated.pm78
-rw-r--r--lib/Lintian/Hint/Pointed.pm88
-rw-r--r--lib/Lintian/IO/Select.pm259
-rw-r--r--lib/Lintian/IPC/Run3.pm135
-rw-r--r--lib/Lintian/Index.pm878
-rw-r--r--lib/Lintian/Index/Ar.pm128
-rw-r--r--lib/Lintian/Index/Elf.pm739
-rw-r--r--lib/Lintian/Index/FileTypes.pm195
-rw-r--r--lib/Lintian/Index/Item.pm1567
-rw-r--r--lib/Lintian/Index/Java.pm258
-rw-r--r--lib/Lintian/Index/Md5sums.pm127
-rw-r--r--lib/Lintian/Index/Strings.pm99
-rw-r--r--lib/Lintian/Mask.pm76
-rw-r--r--lib/Lintian/Output/EWI.pm614
-rw-r--r--lib/Lintian/Output/Grammar.pm84
-rw-r--r--lib/Lintian/Output/HTML.pm331
-rw-r--r--lib/Lintian/Output/JSON.pm322
-rw-r--r--lib/Lintian/Output/Markdown.pm224
-rw-r--r--lib/Lintian/Output/Universal.pm151
-rw-r--r--lib/Lintian/Override.pm86
-rw-r--r--lib/Lintian/Pointer/Item.pm100
-rw-r--r--lib/Lintian/Pool.pm412
-rw-r--r--lib/Lintian/Processable.pm302
-rw-r--r--lib/Lintian/Processable/Buildinfo.pm133
-rw-r--r--lib/Lintian/Processable/Buildinfo/Overrides.pm94
-rw-r--r--lib/Lintian/Processable/Changelog/Version.pm108
-rw-r--r--lib/Lintian/Processable/Changes.pm145
-rw-r--r--lib/Lintian/Processable/Changes/Overrides.pm94
-rw-r--r--lib/Lintian/Processable/Debian/Control.pm90
-rw-r--r--lib/Lintian/Processable/Diffstat.pm162
-rw-r--r--lib/Lintian/Processable/Fields/Files.pm181
-rw-r--r--lib/Lintian/Processable/Hardening.pm105
-rw-r--r--lib/Lintian/Processable/Installable.pm201
-rw-r--r--lib/Lintian/Processable/Installable/Changelog.pm151
-rw-r--r--lib/Lintian/Processable/Installable/Class.pm139
-rw-r--r--lib/Lintian/Processable/Installable/Conffiles.pm97
-rw-r--r--lib/Lintian/Processable/Installable/Control.pm99
-rw-r--r--lib/Lintian/Processable/Installable/Installed.pm103
-rw-r--r--lib/Lintian/Processable/Installable/Overrides.pm131
-rw-r--r--lib/Lintian/Processable/Installable/Relation.pm154
-rw-r--r--lib/Lintian/Processable/IsNonFree.pm109
-rw-r--r--lib/Lintian/Processable/NotJustDocs.pm112
-rw-r--r--lib/Lintian/Processable/Overrides.pm219
-rw-r--r--lib/Lintian/Processable/Source.pm142
-rw-r--r--lib/Lintian/Processable/Source/Changelog.pm109
-rw-r--r--lib/Lintian/Processable/Source/Components.pm126
-rw-r--r--lib/Lintian/Processable/Source/Format.pm136
-rw-r--r--lib/Lintian/Processable/Source/Orig.pm200
-rw-r--r--lib/Lintian/Processable/Source/Overrides.pm109
-rw-r--r--lib/Lintian/Processable/Source/Patched.pm161
-rw-r--r--lib/Lintian/Processable/Source/Relation.pm267
-rw-r--r--lib/Lintian/Processable/Source/Repacked.pm99
-rw-r--r--lib/Lintian/Profile.pm941
-rw-r--r--lib/Lintian/Relation.pm788
-rw-r--r--lib/Lintian/Relation/Predicate.pm553
-rw-r--r--lib/Lintian/Relation/Version.pm213
-rw-r--r--lib/Lintian/Reporting/ResourceManager.pm233
-rw-r--r--lib/Lintian/Reporting/Util.pm217
-rw-r--r--lib/Lintian/Screen.pm80
-rw-r--r--lib/Lintian/Screen/Autotools/LongLines.pm61
-rw-r--r--lib/Lintian/Screen/Coq/Cmxs/Prerequisites.pm49
-rw-r--r--lib/Lintian/Screen/Emacs/Elpa/Scripts.pm50
-rw-r--r--lib/Lintian/Screen/Examples/InTests.pm47
-rw-r--r--lib/Lintian/Screen/Examples/Ship/Devhelp.pm47
-rw-r--r--lib/Lintian/Screen/Glibc/Control/Ldconfig.pm45
-rw-r--r--lib/Lintian/Screen/Python/Egg/Metadata.pm53
-rw-r--r--lib/Lintian/Screen/Toolchain/Gnat/AliReadOnly.pm52
-rw-r--r--lib/Lintian/Screen/Web/Cgi/Scripts.pm48
-rw-r--r--lib/Lintian/SlidingWindow.pm171
-rw-r--r--lib/Lintian/Spelling.pm295
-rw-r--r--lib/Lintian/Storage/MLDBM.pm128
-rw-r--r--lib/Lintian/Tag.pm297
-rw-r--r--lib/Lintian/Util.pm674
-rw-r--r--lib/Lintian/Version.pm122
464 files changed, 75493 insertions, 0 deletions
diff --git a/lib/Lintian/Archive.pm b/lib/Lintian/Archive.pm
new file mode 100644
index 0000000..b9652af
--- /dev/null
+++ b/lib/Lintian/Archive.pm
@@ -0,0 +1,179 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Archive;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use IPC::Run3;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+const my $SLASH => q{/};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+=head1 NAME
+
+Lintian::Archive -- Facilities for archive data
+
+=head1 SYNOPSIS
+
+use Lintian::Archive;
+
+=head1 DESCRIPTION
+
+A class for downloading and accessing archive information
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item mirror_base
+
+=item work_folder
+
+=item packages
+
+=cut
+
+has mirror_base => (is => 'rw', default => 'https://deb.debian.org/debian');
+
+has work_folder => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $work_folder
+ = Path::Tiny->tempdir(TEMPLATE => 'lintian-archive-XXXXXXXXXX');
+
+ return $work_folder;
+ }
+);
+
+has packages => (is => 'rw', default => sub { {} });
+
+=item contents_gz
+
+=cut
+
+sub contents_gz {
+ my ($self, $release, $archive_liberty, $installable_architecture) = @_;
+
+ my $relative
+ = "$release/$archive_liberty/Contents-$installable_architecture.gz";
+ my $local_path = $self->work_folder . $SLASH . $relative;
+
+ return $local_path
+ if -e $local_path;
+
+ path($local_path)->parent->mkpath;
+
+ my $url = $self->mirror_base . "/dists/$relative";
+
+ my $stderr;
+ run3([qw{wget --quiet}, "--output-document=$local_path", $url],
+ undef, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ return $local_path;
+}
+
+=item deb822_packages_by_installable_name
+
+=cut
+
+sub deb822_packages_by_installable_name {
+ my ($self, $release, $archive_liberty, $port) = @_;
+
+ return $self->packages->{$release}{$archive_liberty}{$port}
+ if exists $self->packages->{$release}{$archive_liberty}{$port};
+
+ my $relative_unzipped = "$release/$archive_liberty/binary-$port/Packages";
+ my $local_path = $self->work_folder . $SLASH . $relative_unzipped;
+
+ path($local_path)->parent->mkpath;
+
+ my $url = $self->mirror_base . "/dists/$relative_unzipped.gz";
+
+ my $stderr;
+
+ run3([qw{wget --quiet}, "--output-document=$local_path.gz", $url],
+ undef, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ run3(['gunzip', "$local_path.gz"], undef, \$stderr);
+ $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ my $deb822 = Lintian::Deb822->new;
+ my @sections = $deb822->read_file($local_path);
+
+ unlink($local_path)
+ or die encode_utf8("Cannot delete $local_path");
+
+ my %section_by_installable_name;
+ for my $section (@sections) {
+
+ my $installable_name = $section->value('Package');
+ $section_by_installable_name{$installable_name} = $section;
+ }
+
+ $self->packages->{$release}{$archive_liberty}{$port}
+ = \%section_by_installable_name;
+
+ return \%section_by_installable_name;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Changelog.pm b/lib/Lintian/Changelog.pm
new file mode 100644
index 0000000..84854c3
--- /dev/null
+++ b/lib/Lintian/Changelog.pm
@@ -0,0 +1,380 @@
+# Copyright (C) 2019 Felix Lechner <felix.lechner@lease-up.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Changelog;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp;
+use Const::Fast;
+use Date::Parse;
+
+use Lintian::Changelog::Entry;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $ASTERISK => q{*};
+const my $UNKNOWN => q{unknown};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Changelog -- Parse a literal version string into its constituents
+
+=head1 SYNOPSIS
+
+ use Lintian::Changelog;
+
+ my $version = Lintian::Changelog->new;
+ $version->set('1.2.3-4', undef);
+
+=head1 DESCRIPTION
+
+A class for parsing literal version strings
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new ()
+
+Creates a new Lintian::Changelog object.
+
+=cut
+
+=item find_closes
+
+Takes one string as argument and finds "Closes: #123456, #654321" statements
+as supported by the Debian Archive software in it. Returns all closed bug
+numbers in an array reference.
+
+=cut
+
+sub find_closes {
+ my $changes = shift;
+ my @closes = ();
+
+ while (
+ $changes
+ && ($changes
+ =~ /(closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*)/ig)
+ ) {
+ push(@closes, $1 =~ /\#?\s?(\d+)/g);
+ }
+
+ @closes = sort { $a <=> $b } @closes;
+ return \@closes;
+}
+
+=back
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item parse (STRING)
+
+Parses STRING as the content of a debian/changelog file.
+
+=cut
+
+sub parse {
+ my ($self, $contents) = @_;
+
+ $self->errors([]);
+ $self->entries([]);
+
+ # careful with negative matching /m
+ unless (
+ $contents =~ m{^ \S+ \s* [(] [^\)]+ [)] \s* (?:[^ \t;]+ \s*)+ ; }mx) {
+
+ push(@{$self->errors}, [1, 'not a Debian changelog']);
+ return;
+ }
+
+ my @lines = split(/\n/, $contents);
+
+ # based on /usr/lib/dpkg/parsechangelog/debian
+ my $expect='first heading';
+ my $entry = Lintian::Changelog::Entry->new;
+ my $blanklines = 0;
+
+ # to make unknown version unique, for id
+ my $unknown_version_counter = 1;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ # trim end
+ $line =~ s/\s+\r?$//;
+
+ # print encode_utf*(sprintf(STDERR "%-39.39s %-39.39s\n",$expect,$line));
+ if ($line
+ =~ m/^(?<Source>\w[-+0-9a-z.]*) \((?<Version>[^\(\) \t]+)\)(?<Distribution>(?:\s+[-+0-9a-z.]+)+)\;\s*(?<kvpairs>.*)$/i
+ ){
+ my $source = $+{Source};
+ my $version = $+{Version};
+ my $distribution = $+{Distribution};
+ my $kvpairs = $+{kvpairs};
+
+ unless ($expect eq 'first heading'
+ || $expect eq 'next heading or eof') {
+ $entry->ERROR(
+ [
+ $position,
+ "found start of entry where expected $expect",$line
+ ]
+ );
+ push @{$self->errors}, $entry->ERROR;
+ }
+
+ unless ($entry->is_empty) {
+ $entry->Closes(find_closes($entry->Changes));
+
+ push @{$self->entries}, $entry;
+ $entry = Lintian::Changelog::Entry->new;
+ }
+
+ $entry->position($position);
+
+ $entry->Header($line);
+
+ $entry->Source($source);
+ $entry->Version($version);
+
+ $distribution =~ s/^\s+//;
+ $entry->Distribution($distribution);
+
+ my %kvdone;
+ for my $kv (split(/\s*,\s*/,$kvpairs)) {
+ $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i
+ ||push @{$self->errors},
+ [$position,"bad key-value after ';': '$kv'"];
+ my $k = ucfirst $1;
+ my $v = $2;
+ $kvdone{$k}++
+ && push @{$self->errors},
+ [$position,"repeated key-value $k"];
+ if ($k eq 'Urgency') {
+ $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i
+ ||push @{$self->errors},
+ [$position,"badly formatted urgency value $v"];
+ $entry->Urgency($1);
+ $entry->Urgency_LC(lc($1));
+ $entry->Urgency_Comment($2);
+ } elsif ($k =~ m/^X[BCS]+-/i) {
+ # Extensions - XB for putting in Binary,
+ # XC for putting in Control, XS for putting in Source
+ $entry->{$k}= $v;
+ } else {
+ push @{$self->errors},
+ [$position,
+ "unknown key-value key $k - copying to XS-$k"];
+ $entry->{ExtraFields}{"XS-$k"} = $v;
+ }
+ }
+ $expect= 'start of change data';
+ $blanklines = 0;
+
+ } elsif ($line =~ /^(?:;;\s*)?Local variables:/i) {
+ last; # skip Emacs variables at end of file
+
+ } elsif ($line =~ /^vim:/i) {
+ last; # skip vim variables at end of file
+
+ } elsif ($line =~ /^\$\w+:.*\$/) {
+ next; # skip stuff that look like a CVS keyword
+
+ } elsif ($line =~ /^\# /) {
+ next; # skip comments, even that's not supported
+
+ } elsif ($line =~ m{^/\*.*\*/}) {
+ next; # more comments
+
+ } elsif ($line
+ =~ m/^(?:\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(?:.*)\s+[<\(](?:.*)[\)>]/
+ || $line
+ =~ m/^(?:\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(?:.*)\s+[<\(](?:.*)[\)>]/
+ || $line =~ m/^(?:\w[-+0-9a-z.]*) \((?:[^\(\) \t]+)\)\;?/i
+ || $line =~ m/^(?:[\w.+-]+)[- ]\S+ Debian \S+/i
+ || $line =~ m/^Changes from version (?:.*) to (?:.*):/i
+ || $line =~ m/^Changes for [\w.+-]+-[\w.+-]+:?$/i
+ || fc($line) eq fc('Old Changelog:')
+ || $line =~ m/^(?:\d+:)?\w[\w.+~-]*:?$/) {
+ # save entries on old changelog format verbatim
+ # we assume the rest of the file will be in old format once we
+ # hit it for the first time
+ last;
+
+ } elsif ($line =~ m/^\S/) {
+ push @{$self->errors},
+ [$position,'badly formatted heading line', $line];
+
+ } elsif ($line
+ =~ m/^ \-\- (?<name>.*) <(?<email>.*)>(?<sep> ?)(?<date>(?:\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(?:\s+\([^\\\(\)]\))?)$/
+ ) {
+
+ my $name = $+{name};
+ my $email = $+{email};
+ my $separator = $+{sep};
+ my $date = $+{date};
+
+ $expect eq 'more change data or trailer'
+ || push @{$self->errors},
+ [$position,"found trailer where expected $expect", $line];
+ if ($separator ne $SPACE . $SPACE) {
+ push @{$self->errors},
+ [$position,'badly formatted trailer line', $line];
+ }
+ $entry->Trailer($line);
+ $entry->Maintainer("$name <$email>")
+ unless length $entry->Maintainer;
+
+ unless(length $entry->Date && defined $entry->Timestamp) {
+ $entry->Date($date);
+ $entry->Timestamp(str2time($date));
+ unless (defined $entry->Timestamp) {
+ push @{$self->errors},
+ [$position,"could not parse date $date"];
+ }
+ }
+ $expect = 'next heading or eof';
+
+ } elsif ($line =~ m/^ \-\-/) {
+ $entry->{ERROR}
+ = [$position, 'badly formatted trailer line', $line];
+ push @{$self->errors}, $entry->ERROR;
+ # $expect = 'next heading or eof'
+ # if $expect eq 'more change data or trailer';
+
+ } elsif ($line =~ m/^\s{2,}(\S)/) {
+ $expect eq 'start of change data'
+ || $expect eq 'more change data or trailer'
+ || do {
+ push @{$self->errors},
+ [$position,"found change data where expected $expect",$line];
+ if (($expect eq 'next heading or eof')
+ && !$entry->is_empty) {
+ # lets assume we have missed the actual header line
+ $entry->Closes(find_closes($entry->Changes));
+
+ push @{$self->entries}, $entry;
+
+ $entry = Lintian::Changelog::Entry->new;
+ $entry->Source($UNKNOWN);
+ $entry->Distribution($UNKNOWN);
+ $entry->Urgency($UNKNOWN);
+ $entry->Urgency_LC($UNKNOWN);
+ $entry->Version($UNKNOWN . (++$unknown_version_counter));
+ $entry->Urgency_Comment($EMPTY);
+ $entry->ERROR(
+ [
+ $position,
+ "found change data where expected $expect",$line
+ ]
+ );
+ }
+ };
+ $entry->{'Changes'} .= (" \n" x $blanklines)." $line\n";
+ if (!$entry->{Items} || $1 eq $ASTERISK) {
+ $entry->{Items} ||= [];
+ push @{$entry->{Items}}, "$line\n";
+ } else {
+ $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $line\n";
+ }
+ $blanklines = 0;
+ $expect = 'more change data or trailer';
+
+ } elsif ($line !~ m/\S/) {
+ next
+ if $expect eq 'start of change data'
+ || $expect eq 'next heading or eof';
+ $expect eq 'more change data or trailer'
+ || push @{$self->errors},
+ [$position,"found blank line where expected $expect"];
+ $blanklines++;
+
+ } else {
+ push @{$self->errors}, [$position, 'unrecognised line', $line];
+ ( $expect eq 'start of change data'
+ || $expect eq 'more change data or trailer')
+ && do {
+ # lets assume change data if we expected it
+ $entry->{'Changes'} .= (" \n" x $blanklines)." $line\n";
+ if (!$entry->{Items}) {
+ $entry->{Items} ||= [];
+ push @{$entry->{Items}}, "$line\n";
+ } else {
+ $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $line\n";
+ }
+ $blanklines = 0;
+ $expect = 'more change data or trailer';
+ $entry->ERROR([$position, 'unrecognised line', $line]);
+ };
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ $expect eq 'next heading or eof'
+ || do {
+ $entry->ERROR([$position, "found eof where expected $expect"]);
+ push @{$self->errors}, $entry->ERROR;
+ };
+
+ unless ($entry->is_empty) {
+ $entry->Closes(find_closes($entry->Changes));
+ push @{$self->entries}, $entry;
+ }
+
+ return;
+}
+
+=item errors
+
+=item entries
+
+=cut
+
+has errors => (is => 'rw', default => sub { [] });
+has entries => (is => 'rw', default => sub { [] });
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Changelog/Entry.pm b/lib/Lintian/Changelog/Entry.pm
new file mode 100644
index 0000000..f36cb92
--- /dev/null
+++ b/lib/Lintian/Changelog/Entry.pm
@@ -0,0 +1,184 @@
+#
+# Lintian::Changelog::Entry
+#
+# Copyright (C) 2005 Frank Lichtenheld <frank@lichtenheld.de>
+# Copyright (C) 2019 Felix Lechner <felix.lechner@lease-up.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+package Lintian::Changelog::Entry;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $UNKNOWN => q{unknown};
+
+has Changes => (is => 'rw', default => $EMPTY);
+has Closes => (is => 'rw');
+has Date => (is => 'rw');
+has Distribution => (is => 'rw');
+has Header => (is => 'rw');
+#has Items => (is => 'rw', default => sub { [] });
+has Maintainer => (is => 'rw');
+has Source => (is => 'rw');
+has Timestamp => (is => 'rw');
+has Trailer => (is => 'rw');
+has Urgency => (is => 'rw', default => $UNKNOWN);
+has Urgency_LC => (is => 'rw', default => $UNKNOWN);
+has Urgency_Comment => (is => 'rw', default => $EMPTY);
+has Version => (is => 'rw');
+has ERROR => (is => 'rw');
+has position => (is => 'rw');
+
+=head1 NAME
+
+Lintian::Changelog::Entry - represents one entry in a Debian changelog
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head2 Methods
+
+=head3 init
+
+Creates a new object, no options.
+
+=head3 new
+
+Alias for init.
+
+=head3 is_empty
+
+Checks if the object is actually initialized with data. Due to limitations
+in Parse::DebianChangelog this currently simply checks if one of the
+fields Source, Version, Maintainer, Date, or Changes is initialized.
+
+=head2 Accessors
+
+The following fields are available via accessor functions (all
+fields are string values unless otherwise noted):
+
+=over 4
+
+=item Source
+
+=item Version
+
+=item Distribution
+
+=item Urgency
+
+=item Urgency_Comment
+
+=item C<Urgency_LC>
+
+=item C<ExtraFields>
+
+Extra_Fields (all fields except for urgency as hash; POD spelling forces the underscore)
+
+=item Header
+
+Header (the whole header in verbatim form)
+
+=item Changes
+
+Changes (the actual content of the bug report, in verbatim form)
+
+=item Trailer
+
+Trailer (the whole trailer in verbatim form)
+
+=item Closes
+
+Closes (Array of bug numbers)
+
+=item Maintainer
+
+=item C<MaintainerEmail>
+
+=item Date
+
+=item Timestamp
+
+Timestamp (Date expressed in seconds since the epoch)
+
+=item ERROR
+
+Last parse error related to this entry in the format described
+at Parse::DebianChangelog::get_parse_errors.
+
+=item position
+
+=back
+
+=begin Pod::Coverage
+
+Changes
+Closes
+Date
+Distribution
+Header
+Maintainer
+C<MaintainerEmail>
+Source
+Timestamp
+Trailer
+
+=end Pod::Coverage
+
+=cut
+
+sub is_empty {
+ my ($self) = @_;
+
+ return !(length $self->Changes
+ || length $self->Source
+ || length $self->Version
+ || length $self->Maintainer
+ || length $self->Date);
+}
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Originally based on Parse::DebianChangelog by Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt>
+
+=head1 AUTHOR
+
+Written by Felix Lechner <felix.lechner@lease-up.com> for Lintian in response to #933134.
+
+=head1 COPYRIGHT AND LICENSE
+
+Please see in the code; FSF's standard short text triggered a POD spelling error
+here.
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Changelog/Version.pm b/lib/Lintian/Changelog/Version.pm
new file mode 100644
index 0000000..d0e29f4
--- /dev/null
+++ b/lib/Lintian/Changelog/Version.pm
@@ -0,0 +1,250 @@
+# Copyright (C) 2019 Felix Lechner <felix.lechner@lease-up.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Changelog::Version;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp;
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+const my $EMPTY => q{};
+
+=head1 NAME
+
+Lintian::Changelog::Version -- Parse a literal version string into its constituents
+
+=head1 SYNOPSIS
+
+ use Lintian::Changelog::Version;
+
+ my $version = Lintian::Changelog::Version->new;
+ $version->assign('1.2.3-4', undef);
+
+=head1 DESCRIPTION
+
+A class for parsing literal version strings
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new ()
+
+Creates a new Lintian::Changelog::Version object.
+
+=cut
+
+=back
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item assign (LITERAL, NATIVE)
+
+Assign the various members in the Lintian::Changelog::Version object
+using the LITERAL version string and the NATIVE boolean selector.
+
+=cut
+
+sub assign {
+
+ my ($self, $literal, $native) = @_;
+
+ croak encode_utf8('Literal version string required for version parsing')
+ unless defined $literal;
+
+ croak encode_utf8('Native flag required for version parsing')
+ unless defined $native;
+
+ my $epoch_pattern = qr/([0-9]+)/;
+ my $upstream_pattern = qr/([A-Za-z0-9.+\-~]+?)/;
+ my $maintainer_revision_pattern = qr/([A-Za-z0-9.+~]+?)/;
+ my $source_nmu_pattern = qr/([A-Za-z0-9.+~]+)/;
+ my $bin_nmu_pattern = qr/([0-9]+)/;
+
+ my $source_pattern;
+
+ # these capture three matches each
+ $source_pattern
+ = qr/$upstream_pattern/
+ . qr/(?:-$maintainer_revision_pattern(?:\.$source_nmu_pattern)?)?/
+ if !$native;
+ $source_pattern
+ = qr/()/
+ . qr/$maintainer_revision_pattern/
+ . qr/(?:\+nmu$source_nmu_pattern)?/
+ if $native;
+
+ my $pattern
+ = qr/^/
+ . qr/(?:$epoch_pattern:)?/
+ . qr/$source_pattern/
+ . qr/(?:\+b$bin_nmu_pattern)?/. qr/$/;
+
+ my ($epoch, $upstream, $maintainer_revision, $source_nmu, $binary_nmu)
+ = ($literal =~ $pattern);
+
+ $epoch //= $EMPTY;
+ $upstream //= $EMPTY;
+ $maintainer_revision //= $EMPTY;
+ $source_nmu //= $EMPTY;
+ $binary_nmu //= $EMPTY;
+
+ my $source_nmu_string = $EMPTY;
+
+ $source_nmu_string = ($native ? "+nmu$source_nmu" : ".$source_nmu")
+ if length $source_nmu;
+
+ my $debian_source = $maintainer_revision . $source_nmu_string;
+
+ my $debian_no_epoch
+ = $debian_source . (length $binary_nmu ? "+b$binary_nmu" : $EMPTY);
+
+ my $upstream_string = (length $upstream ? "$upstream-" : $EMPTY);
+
+ my $no_epoch= $upstream_string . $debian_no_epoch;
+
+ my $epoch_string = (length $epoch ? "$epoch:" : $EMPTY);
+
+ my $reconstructed= $epoch_string . $no_epoch;
+
+ croak encode_utf8(
+ "Failed to parse package version: $reconstructed ne $literal")
+ unless $reconstructed eq $literal;
+
+ $self->literal($literal);
+ $self->epoch($epoch);
+ $self->no_epoch($no_epoch);
+ $self->upstream($upstream);
+ $self->maintainer_revision($maintainer_revision);
+ $self->debian_source($debian_source);
+ $self->debian_no_epoch($debian_no_epoch);
+ $self->source_nmu($source_nmu);
+ $self->binary_nmu($binary_nmu);
+
+ my $without_source_nmu
+ = $epoch_string . $upstream_string . $maintainer_revision;
+
+ $self->without_source_nmu($without_source_nmu);
+
+ my $backport_pattern = qr/^(.*)[+~]deb(\d+)u(\d+)$/;
+
+ my ($debian_without_backport, $backport_release, $backport_revision)
+ = ($self->maintainer_revision =~ $backport_pattern);
+
+ $debian_without_backport //= $maintainer_revision;
+ $backport_release //= $EMPTY;
+ $backport_revision //= $EMPTY;
+
+ $self->debian_without_backport($debian_without_backport);
+ $self->backport_release($backport_release);
+ $self->backport_revision($backport_revision);
+
+ my $without_backport
+ = $epoch_string . $upstream_string . $debian_without_backport;
+
+ $self->without_backport($without_backport);
+
+ return;
+}
+
+=item literal
+
+=item epoch
+
+=item no_epoch
+
+=item upstream
+
+=item maintainer_revision
+
+=item debian_source
+
+=item debian_no_epoch
+
+=item source_nmu
+
+=item binary_nmu
+
+=item without_source_nmu
+
+=item debian_without_backport
+
+=item backport_release
+
+=item backport_revision
+
+=item without_backport
+
+=cut
+
+has literal => (is => 'rw', default => $EMPTY);
+
+has epoch => (is => 'rw', default => $EMPTY);
+
+has no_epoch => (is => 'rw', default => $EMPTY);
+
+has upstream => (is => 'rw', default => $EMPTY);
+
+has maintainer_revision => (is => 'rw', default => $EMPTY);
+
+has debian_source => (is => 'rw', default => $EMPTY);
+
+has debian_no_epoch => (is => 'rw', default => $EMPTY);
+
+has source_nmu => (is => 'rw', default => $EMPTY);
+
+has binary_nmu => (is => 'rw', default => $EMPTY);
+
+has without_source_nmu => (is => 'rw', default => $EMPTY);
+
+has debian_without_backport => (is => 'rw', default => $EMPTY);
+
+has backport_release => (is => 'rw', default => $EMPTY);
+
+has backport_revision => (is => 'rw', default => $EMPTY);
+
+has without_backport => (is => 'rw', default => $EMPTY);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check.pm b/lib/Lintian/Check.pm
new file mode 100644
index 0000000..02e459f
--- /dev/null
+++ b/lib/Lintian/Check.pm
@@ -0,0 +1,232 @@
+# Copyright (C) 2012 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2019-2021 Felix Lechner <felix.lechner@lease-up.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Hint::Annotated;
+use Lintian::Hint::Pointed;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $UNDERSCORE => q{_};
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Check -- Common facilities for Lintian checks
+
+=head1 SYNOPSIS
+
+ use Moo;
+ use namespace::clean;
+
+ with('Lintian::Check');
+
+=head1 DESCRIPTION
+
+A class for operating Lintian checks
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item name
+
+=item processable
+
+=item group
+
+=item profile
+
+=item hints
+
+=cut
+
+has name => (is => 'rw', default => $EMPTY);
+has processable => (is => 'rw', default => sub { {} });
+has group => (is => 'rw', default => sub { {} });
+has profile => (is => 'rw');
+
+has hints => (is => 'rw', default => sub { [] });
+
+=item data
+
+=cut
+
+sub data {
+ my ($self) = @_;
+
+ return $self->profile->data;
+}
+
+=item visit_files
+
+=cut
+
+sub visit_files {
+ my ($self, $index) = @_;
+
+ my $visit_hook = 'visit' . $UNDERSCORE . $index . $UNDERSCORE . 'files';
+
+ return
+ unless $self->can($visit_hook);
+
+ my @items = @{$self->processable->$index->sorted_list};
+
+ # do not look inside quilt directory
+ @items = grep { $_->name !~ m{^\.pc/} } @items
+ if $index eq 'patched';
+
+ # exclude Lintian's test suite from source scans
+ @items = grep { $_->name !~ m{^t/} } @items
+ if $self->processable->name eq 'lintian' && $index eq 'patched';
+
+ $self->$visit_hook($_) for @items;
+
+ return;
+}
+
+=item run
+
+=cut
+
+sub run {
+ my ($self) = @_;
+
+ # do not carry over any hints
+ $self->hints([]);
+
+ my $type = $self->processable->type;
+
+ if ($type eq 'source') {
+
+ $self->visit_files('orig');
+ $self->visit_files('patched');
+ }
+
+ if ($type eq 'binary' || $type eq 'udeb') {
+
+ $self->visit_files('control');
+ $self->visit_files('installed');
+
+ $self->installable
+ if $self->can('installable');
+ }
+
+ $self->$type
+ if $self->can($type);
+
+ $self->always
+ if $self->can('always');
+
+ return @{$self->hints};
+}
+
+=item pointed_hint
+
+=cut
+
+sub pointed_hint {
+ my ($self, $tag_name, $pointer, @notes) = @_;
+
+ my $hint = Lintian::Hint::Pointed->new;
+
+ $hint->tag_name($tag_name);
+ $hint->issued_by($self->name);
+
+ my $note = stringify(@notes);
+ $hint->note($note);
+ $hint->pointer($pointer);
+
+ push(@{$self->hints}, $hint);
+
+ return;
+}
+
+=item hint
+
+=cut
+
+sub hint {
+ my ($self, $tag_name, @notes) = @_;
+
+ my $hint = Lintian::Hint::Annotated->new;
+
+ $hint->tag_name($tag_name);
+ $hint->issued_by($self->name);
+
+ my $note = stringify(@notes);
+ $hint->note($note);
+
+ push(@{$self->hints}, $hint);
+
+ return;
+}
+
+=item stringify
+
+=cut
+
+sub stringify {
+ my (@arguments) = @_;
+
+ # skip empty arguments
+ my @meaningful = grep { length } @arguments;
+
+ # trim both ends of each item
+ s{^ \s+ | \s+ $}{}gx for @meaningful;
+
+ # concatenate with spaces
+ my $text = join($SPACE, @meaningful) // $EMPTY;
+
+ # escape newlines; maybe add others
+ $text =~ s{\n}{\\n}g;
+
+ return $text;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Apache2.pm b/lib/Lintian/Check/Apache2.pm
new file mode 100644
index 0000000..b8dde2d
--- /dev/null
+++ b/lib/Lintian/Check/Apache2.pm
@@ -0,0 +1,337 @@
+# apache2 -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2012 Arno Toell
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Apache2;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use File::Basename;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# whether the package appears to be an Apache2 module/web application
+has is_apache2_related => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ return 1
+ if $item->name =~ m{^ usr/lib/apache2/modules/ }x
+ && $item->basename =~ m{ [.]so $}x;
+
+ return 1
+ if $item->name
+ =~ m{^ etc/apache2/ (?:conf|site) - (?:available|enabled) / }x;
+
+ return 1
+ if $item->name =~ m{^ etc/apache2/conf[.]d/}x;
+ }
+
+ return 0;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # Do nothing if the package in question appears to be related to
+ # the web server itself
+ return
+ if $self->processable->name =~ m/^apache2(:?\.2)?(?:-\w+)?$/;
+
+ # File is probably not relevant to us, ignore it
+ return
+ if $item->is_dir;
+
+ return
+ if $item->name !~ m{^(?:usr/lib/apache2/modules/|etc/apache2/)};
+
+ # Package installs an unrecognized file - check this for all files
+ if ( $item->name !~ /\.conf$/
+ && $item->name =~ m{^etc/apache2/(conf|site|mods)-available/(.*)$}){
+
+ my $temp_type = $1;
+ my $temp_file = $2;
+
+ # ... except modules which are allowed to ship .load files
+ $self->pointed_hint('apache2-configuration-files-need-conf-suffix',
+ $item->pointer)
+ unless $temp_type eq 'mods' && $temp_file =~ /\.load$/;
+ }
+
+ # Package appears to be a binary module
+ if ($item->name =~ m{^usr/lib/apache2/modules/(.*)\.so$}) {
+
+ $self->check_module_package($item, $1);
+ }
+
+ # Package appears to be a web application
+ elsif ($item->name =~ m{^etc/apache2/(conf|site)-available/(.*)$}) {
+
+ $self->check_web_application_package($item, $1, $2);
+ }
+
+ # Package appears to be a legacy web application
+ elsif ($item->name =~ m{^etc/apache2/conf\.d/(.*)$}) {
+
+ $self->pointed_hint(
+ 'apache2-reverse-dependency-uses-obsolete-directory',
+ $item->pointer);
+ $self->check_web_application_package($item,'conf', $1);
+ }
+
+ # Package does scary things
+ elsif ($item->name =~ m{^etc/apache2/(?:conf|sites|mods)-enabled/.*$}) {
+
+ $self->pointed_hint(
+ 'apache2-reverse-dependency-ships-file-in-not-allowed-directory',
+ $item->pointer);
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ # Do nothing if the package in question appears to be related to
+ # the web server itself
+ return
+ if $self->processable->name =~ m/^apache2(:?\.2)?(?:-\w+)?$/;
+
+ return;
+}
+
+sub check_web_application_package {
+ my ($self, $item, $pkgtype, $webapp) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+
+ $self->pointed_hint('non-standard-apache2-configuration-name',
+ $item->pointer, "$webapp != $pkg.conf")
+ if $webapp ne "$pkg.conf"
+ || $webapp =~ /^local-/;
+
+ my $rel = $processable->relation('strong')
+ ->logical_and($processable->relation('Recommends'));
+
+ # A web application must not depend on apache2-whatever
+ my $visit = sub {
+ if (m/^apache2(?:\.2)?-(?:common|data|bin)$/) {
+ $self->pointed_hint(
+ 'web-application-depends-on-apache2-data-package',
+ $item->pointer, $_, $webapp);
+ return 1;
+ }
+ return 0;
+ };
+ $rel->visit($visit, Lintian::Relation::VISIT_STOP_FIRST_MATCH);
+
+ # ... nor on apache2 only. Moreover, it should be in the form
+ # apache2 | httpd but don't worry about versions, virtual package
+ # don't support that
+ $self->pointed_hint('web-application-works-only-with-apache',
+ $item->pointer, $webapp)
+ if $rel->satisfies('apache2');
+
+ $self->inspect_conf_file($pkgtype, $item);
+ return;
+}
+
+sub check_module_package {
+ my ($self, $item, $module) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+
+ # We want packages to be follow our naming scheme. Modules should be named
+ # libapache2-mod-<foo> if it ships a mod_foo.so
+ # NB: Some modules have uppercase letters in them (e.g. Ruwsgi), but
+ # obviously the package should be in all lowercase.
+ my $expected_name = 'libapache2-' . lc($module);
+
+ my $rel;
+
+ $expected_name =~ tr/_/-/;
+ $self->pointed_hint('non-standard-apache2-module-package-name',
+ $item->pointer, "$pkg != $expected_name")
+ if $expected_name ne $pkg;
+
+ $rel = $processable->relation('strong')
+ ->logical_and($processable->relation('Recommends'));
+
+ $self->pointed_hint('apache2-module-does-not-depend-on-apache2-api',
+ $item->pointer)
+ if !$rel->matches(qr/^apache2-api-\d+$/);
+
+ # The module is called mod_foo.so, thus the load file is expected to be
+ # named foo.load
+ my $load_file = $module;
+ my $conf_file = $module;
+ $load_file =~ s{^mod.(.*)$}{etc/apache2/mods-available/$1.load};
+ $conf_file =~ s{^mod.(.*)$}{etc/apache2/mods-available/$1.conf};
+
+ if (my $f = $processable->installed->lookup($load_file)) {
+ $self->inspect_conf_file('mods', $f);
+ } else {
+ $self->pointed_hint('apache2-module-does-not-ship-load-file',
+ $item->pointer, $load_file);
+ }
+
+ if (my $f = $processable->installed->lookup($conf_file)) {
+ $self->inspect_conf_file('mods', $f);
+ }
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $self->is_apache2_related;
+
+ return
+ unless $item->is_maintainer_script;
+
+ # skip anything but shell scripts
+ return
+ unless $item->is_shell_script;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $sfd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$sfd>) {
+
+ # skip comments
+ next
+ if $line =~ /^ [#]/x;
+
+ # Do not allow reverse dependencies to call "a2enmod" and friends
+ # directly
+ if ($line =~ m{ \b (a2(?:en|dis)(?:conf|site|mod)) \b }x) {
+
+ my $command = $1;
+
+ $self->pointed_hint(
+ 'apache2-reverse-dependency-calls-wrapper-script',
+ $item->pointer($position), $command);
+ }
+
+ # Do not allow reverse dependencies to call "invoke-rc.d apache2
+ $self->pointed_hint('apache2-reverse-dependency-calls-invoke-rc.d',
+ $item->pointer($position))
+ if $line =~ /invoke-rc\.d\s+apache2/;
+
+ # XXX: Check whether apache2-maintscript-helper is used
+ # unconditionally e.g. not protected by a [ -e ], [ -x ] or so.
+ # That's going to be complicated. Or not possible without grammar
+ # parser.
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+sub inspect_conf_file {
+ my ($self, $conftype, $item) = @_;
+
+ # Don't follow unsafe links
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $skip = 0;
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ ++$skip
+ if $line =~ m{<\s*IfModule.*!\s*mod_authz_core}
+ || $line =~ m{<\s*IfVersion\s+<\s*2\.3};
+
+ for my $directive ('Order', 'Satisfy', 'Allow', 'Deny',
+ qr{</?Limit.*?>}xsm, qr{</?LimitExcept.*?>}xsm) {
+
+ if ($line =~ m{\A \s* ($directive) (?:\s+|\Z)}xsm && !$skip) {
+
+ $self->pointed_hint('apache2-deprecated-auth-config',
+ $item->pointer($position), $1);
+ }
+ }
+
+ if ($line =~ /^#\s*(Depends|Conflicts):\s+(.*?)\s*$/) {
+ my ($field, $value) = ($1, $2);
+
+ $self->pointed_hint('apache2-unsupported-dependency',
+ $item->pointer($position), $field)
+ if $field eq 'Conflicts' && $conftype ne 'mods';
+
+ my @dependencies = split(/[\n\s]+/, $value);
+ for my $dep (@dependencies) {
+
+ $self->pointed_hint('apache2-unparsable-dependency',
+ $item->pointer($position), $dep)
+ if $dep =~ /[^\w\.]/
+ || $dep =~ /^mod\_/
+ || $dep =~ /\.(?:conf|load)/;
+ }
+ }
+
+ --$skip
+ if $line =~ m{<\s*/\s*If(Module|Version)};
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/ApplicationNotLibrary.pm b/lib/Lintian/Check/ApplicationNotLibrary.pm
new file mode 100644
index 0000000..a598385
--- /dev/null
+++ b/lib/Lintian/Check/ApplicationNotLibrary.pm
@@ -0,0 +1,141 @@
+# application-not-library -- find applications packaged like a library -*- perl -*-
+#
+# Copyright (C) 2014-2015 Axel Beckert <abe@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::ApplicationNotLibrary;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ # big exception list for all tags
+ return
+ # perl itself
+ if $self->processable->name =~ /^perl(?:-base)?$/
+ # ruby itself
+ || $self->processable->name =~ /^ruby[\d.]*$/
+ # python itself
+ || $self->processable->name =~ /^python[\d.]*(?:-dev|-minimal)?$/
+ # cpan related tools
+ || $self->processable->name =~ /^cpan/
+ # perl module tools
+ || $self->processable->name =~ /^libmodule-.*-perl$/
+ # perl debugging tools
+ || $self->processable->name =~ /^libdevel-.*-perl$/
+ # perl-handling tools
+ || $self->processable->name =~ /^libperl.*-perl$/
+ # perl testing tools
+ || $self->processable->name =~ /^libtest-.*-perl$/
+ # python packaging stuff
+ || $self->processable->name =~ /^python[\d.]*-(?:stdeb|setuptools)$/
+ # ruby packaging stuff
+ || $self->processable->name =~ /^gem2deb/
+ # rendering engine
+ || $self->processable->name =~ /^xulrunner/
+ # generic helpers
+ || $self->processable->name =~ /^lib.*-(?:utils|tools|bin|dev)/
+ # whitelist
+ || (
+ any { $self->processable->name eq $_ }
+ qw(
+
+ rake
+ bundler
+ coderay
+ kdelibs-bin
+ libapp-options-perl
+
+ )
+ );
+
+ my @programs;
+ for my $searched_folder (qw{bin sbin usr/bin usr/sbin usr/games}) {
+
+ my $directory_item
+ = $self->processable->installed->lookup("$searched_folder/");
+ next
+ unless defined $directory_item;
+
+ for my $program_item ($directory_item->children) {
+
+ # ignore debhelper plugins
+ next
+ if $program_item->basename =~ /^dh_/;
+
+ # ignore library configuration tools
+ next
+ if $program_item->name =~ /properties$/;
+
+ # ignore library maintenance tools
+ next
+ if $program_item->name =~ /update$/;
+
+ push(@programs, $program_item);
+ }
+ }
+
+ return
+ unless @programs;
+
+ # check for library style package names
+ if ( $self->processable->name =~ m{^ lib (?:.+) -perl $}x
+ || $self->processable->name =~ m{^ruby-}x
+ || $self->processable->name =~ m{^python[\d.]*-}x) {
+
+ if ($self->processable->name =~ m{^ libapp (?:.+) -perl $}x) {
+ $self->pointed_hint('libapp-perl-package-name', $_->pointer)
+ for @programs;
+
+ } else {
+ $self->pointed_hint('library-package-name-for-application',
+ $_->pointer)
+ for @programs;
+ }
+ }
+
+ my $section = $self->processable->fields->value('Section');
+
+ # oldlibs is ok
+ if ($section =~ m{ perl | python | ruby | (?: ^ | / ) libs }x) {
+
+ $self->pointed_hint('application-in-library-section',
+ $_->pointer, $section)
+ for @programs;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/AppstreamMetadata.pm b/lib/Lintian/Check/AppstreamMetadata.pm
new file mode 100644
index 0000000..97a57d4
--- /dev/null
+++ b/lib/Lintian/Check/AppstreamMetadata.pm
@@ -0,0 +1,269 @@
+# appstream-metadata -- lintian check script -*- perl -*-
+
+# Copyright (C) 2016 Petter Reinholdtsen
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::AppstreamMetadata;
+
+# For .desktop files, the lintian check would be really easy: Check if
+# .desktop file is there, check if matching file exists in
+# /usr/share/metainfo, if not throw a warning. Maybe while we're at it
+# also check for legacy locations (stuff in /usr/share/appdata) and
+# legacy data (metainfo files starting with `<application>`).
+#
+# For modaliases, maybe udev rules could give some hints.
+# Check modalias values to ensure hex numbers are using capital A-F.
+
+use v5.20;
+use warnings;
+use utf8;
+use autodie qw(open);
+
+use File::Basename qw(basename);
+use Syntax::Keyword::Try;
+use XML::LibXML;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $type = $self->processable->type;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my (%desktopfiles, %metainfo, @udevrules);
+ my $found_modalias = 0;
+ my $modaliases = [];
+ if (
+ defined(
+ my $dir
+ = $processable->installed->resolve_path(
+ 'usr/share/applications/')
+ )
+ ) {
+ for my $item ($dir->descendants) {
+ $desktopfiles{$item} = 1 if ($item->is_file);
+ }
+ }
+ if (
+ defined(
+ my $dir
+ = $processable->installed->resolve_path('usr/share/metainfo/')
+ )
+ ) {
+ for my $item ($dir->children) {
+ if ($item->is_file) {
+ $metainfo{$item} = 1;
+ $found_modalias|= $self->check_modalias($item, $modaliases);
+ }
+ }
+ }
+ if (
+ defined(
+ my $dir
+ = $processable->installed->resolve_path('usr/share/appdata/')
+ )
+ ) {
+ for my $item ($dir->descendants) {
+ if ($item->is_file) {
+
+ $self->pointed_hint('appstream-metadata-in-legacy-location',
+ $item->pointer);
+ $found_modalias|= $self->check_modalias($item, $modaliases);
+ }
+ }
+ }
+ foreach my $lib_dir (qw(usr/lib lib)) {
+ if (
+ defined(
+ my $dir = $processable->installed->resolve_path(
+ "$lib_dir/udev/rules.d/")
+ )
+ ) {
+ for my $item ($dir->descendants) {
+ push(@udevrules, $item) if ($item->is_file);
+ }
+ }
+ }
+
+ for my $udevrule (@udevrules) {
+ if ($self->check_udev_rules($udevrule, $modaliases)
+ && !$found_modalias) {
+
+ $self->hint('appstream-metadata-missing-modalias-provide',
+ $udevrule);
+ }
+ }
+ return;
+}
+
+sub check_modalias {
+ my ($self, $item, $modaliases) = @_;
+
+ if (!$item->is_open_ok) {
+ # FIXME report this as an error
+ return 0;
+ }
+
+ my $parser = XML::LibXML->new;
+ $parser->set_option('no_network', 1);
+
+ my $doc;
+ try {
+ $doc = $parser->parse_file($item->unpacked_path);
+
+ } catch {
+
+ $self->pointed_hint('appstream-metadata-invalid',$item->pointer);
+
+ return 0;
+ }
+
+ return 0
+ unless $doc;
+
+ if ($doc->findnodes('/application')) {
+
+ $self->pointed_hint('appstream-metadata-legacy-format',$item->pointer);
+ return 0;
+ }
+
+ my @provides = $doc->findnodes('/component/provides');
+ return 0
+ unless @provides;
+
+ # take first one
+ my $first = $provides[0];
+ return 0
+ unless $first;
+
+ my @nodes = $first->getChildrenByTagName('modalias');
+ return 0
+ unless @nodes;
+
+ for my $node (@nodes) {
+
+ my $alias = $node->firstChild->data;
+ next
+ unless $alias;
+
+ push(@{$modaliases}, $alias);
+
+ $self->pointed_hint('appstream-metadata-malformed-modalias-provide',
+ $item->pointer,
+ "include non-valid hex digit in USB matching rule '$alias'")
+ if $alias =~ /^usb:v[0-9a-f]{4}p[0-9a-f]{4}d/i
+ && $alias !~ /^usb:v[0-9A-F]{4}p[0-9A-F]{4}d/;
+ }
+
+ return 1;
+}
+
+sub provides_user_device {
+ my ($self, $item, $position, $rule, $data) = @_;
+
+ my $retval = 0;
+
+ if ( $rule =~ /plugdev/
+ || $rule =~ /uaccess/
+ || $rule =~ /MODE=\"0666\"/) {
+
+ $retval = 1;
+ }
+
+ if ($rule =~ m/SUBSYSTEM=="usb"/) {
+ my ($vmatch, $pmatch);
+ if ($rule =~ m/ATTR\{idVendor\}=="([0-9a-fA-F]{4})"/) {
+ $vmatch = 'v' . uc($1);
+ }
+
+ if ($rule =~ m/ATTR\{idProduct\}=="([0-9a-fA-F]{4})"/) {
+ $pmatch = 'p' . uc($1);
+ }
+
+ if (defined $vmatch && defined $pmatch) {
+ my $match = "usb:${vmatch}${pmatch}d";
+ my $foundmatch;
+ for my $aliasmatch (@{$data}) {
+ if (0 == index($aliasmatch, $match)) {
+ $foundmatch = 1;
+ }
+ }
+
+ $self->pointed_hint(
+ 'appstream-metadata-missing-modalias-provide',
+ $item->pointer($position),
+ "match rule $match*"
+ ) unless $foundmatch;
+ }
+ }
+
+ return $retval;
+}
+
+sub check_udev_rules {
+ my ($self, $item, $data) = @_;
+
+ open(my $fd, '<', $item->unpacked_path);
+
+ my $cont;
+ my $retval = 0;
+
+ my $position = 0;
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ if (defined $cont) {
+ $line = $cont . $line;
+ $cont = undef;
+ }
+
+ if ($line =~ /^(.*)\\$/) {
+ $cont = $1;
+ next;
+ }
+
+ # skip comments
+ next
+ if $line =~ /^#.*/;
+
+ $retval |= $self->provides_user_device($item, $position, $line, $data);
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return $retval;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Apt.pm b/lib/Lintian/Check/Apt.pm
new file mode 100644
index 0000000..08b5ce6
--- /dev/null
+++ b/lib/Lintian/Check/Apt.pm
@@ -0,0 +1,69 @@
+# apt -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Apt;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $self->processable->source_name eq 'apt';
+
+ # /etc/apt/preferences
+ $self->pointed_hint('package-installs-apt-preferences', $item->pointer)
+ if $item->name =~ m{^ etc/apt/preferences (?: $ | [.]d / [^/]+ ) }x;
+
+ # /etc/apt/sources
+ unless ($self->processable->name =~ m{ -apt-source $}x) {
+
+ $self->pointed_hint('package-installs-apt-sources', $item->pointer)
+ if $item->name
+ =~ m{^ etc/apt/sources[.]list (?: $ | [.]d / [^/]+ ) }x;
+ }
+
+ # /etc/apt/trusted.gpg
+ unless (
+ $self->processable->name=~ m{ (?: -apt-source | -archive-keyring ) $}x)
+ {
+
+ $self->pointed_hint('package-installs-apt-keyring', $item->pointer)
+ if $item->name=~ m{^ etc/apt/trusted[.]gpg (?: $ | [.]d / [^/]+ ) }x;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Archive/File/Name/Length.pm b/lib/Lintian/Check/Archive/File/Name/Length.pm
new file mode 100644
index 0000000..212a6b9
--- /dev/null
+++ b/lib/Lintian/Check/Archive/File/Name/Length.pm
@@ -0,0 +1,93 @@
+# archive/file/name/length -- lintian check script -*- perl -*-
+
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Archive::File::Name::Length;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+const my $FILENAME_LENGTH_LIMIT => 80;
+
+# We could derive this from data/fields/architectures, but that
+# contains things like kopensolaris-sparc64 and kfreebsd-sparc64,
+# neither of which Debian officially supports.
+const my $LONGEST_ARCHITECTURE => length 'kfreebsd-amd64';
+
+sub always {
+ my ($self) = @_;
+
+ # Skip auto-generated packages (dbgsym)
+ return
+ if $self->processable->fields->declares('Auto-Built-Package');
+
+ my $basename = basename($self->processable->path);
+ # remove salsaci suffix
+ my $nosalsabasename = $basename;
+ $nosalsabasename
+ =~ s/[+]salsaci[+]\d+[+]\d+(_[[:alnum:]]+\.[[:alnum:]]+)$/$1/;
+
+ my $adjusted_length
+ = length($nosalsabasename)
+ - length($self->processable->architecture)
+ + $LONGEST_ARCHITECTURE;
+
+ $self->hint('package-has-long-file-name', $basename)
+ if $adjusted_length > $FILENAME_LENGTH_LIMIT;
+
+ return;
+}
+
+sub source {
+ my ($self) = @_;
+
+ my @lines = $self->processable->fields->trimmed_list('Files', qr/\n/);
+
+ for my $line (@lines) {
+
+ my (undef, undef, $name) = split($SPACE, $line);
+ next
+ unless length $name;
+
+ $self->hint('source-package-component-has-long-file-name', $name)
+ if length $name > $FILENAME_LENGTH_LIMIT;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Archive/Liberty/Mismatch.pm b/lib/Lintian/Check/Archive/Liberty/Mismatch.pm
new file mode 100644
index 0000000..6d050f6
--- /dev/null
+++ b/lib/Lintian/Check/Archive/Liberty/Mismatch.pm
@@ -0,0 +1,138 @@
+# archive/liberty/mismatch -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Archive::Liberty::Mismatch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(all none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $ARROW => q{->};
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ # Check that every package is in the same archive area, except
+ # that sources in main can deliver both main and contrib packages.
+ # The source package may or may not have a section specified; if
+ # it doesn't, derive the expected archive area from the first
+ # binary package by leaving $source_liberty undefined until parsing the
+ # first binary section. Missing sections will be caught by other
+ # checks.
+
+ my $source_section = $source_fields->value('Section');
+ return
+ unless length $source_section;
+
+ # see policy 2.4
+ $source_section = "main/$source_section"
+ if $source_section !~ m{/};
+
+ my $source_liberty = $source_section;
+ $source_liberty =~ s{ / .* $}{}x;
+
+ my %liberty_by_installable;
+
+ for my $installable ($control->installables) {
+
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $installable_section;
+ if ($installable_fields->declares('Section')) {
+
+ $installable_section = $installable_fields->value('Section');
+
+ # see policy 2.4
+ $installable_section = "main/$installable_section"
+ if $installable_section !~ m{/};
+ }
+
+ $installable_section ||= $source_section;
+
+ my $installable_liberty = $installable_section;
+ $installable_liberty =~ s{ / .* $}{}x;
+
+ $liberty_by_installable{$installable} = $installable_liberty;
+
+ # special exception for contrib built from main
+ next
+ if $source_liberty eq 'main' && $installable_liberty eq 'contrib';
+
+ # and non-free-firmware built from non-free
+ next
+ if $source_liberty eq 'non-free'
+ && $installable_liberty eq 'non-free-firmware';
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position('Section');
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('archive-liberty-mismatch', $pointer,
+ "(in section for $installable)",
+ $installable_liberty, 'vs', $source_liberty)
+ if $source_liberty ne $installable_liberty;
+ }
+
+ # in ascending order of liberty
+ for my $inferior_liberty ('non-free', 'contrib') {
+
+ # must remain inferior
+ last
+ if $inferior_liberty eq $source_liberty;
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position('Section');
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('archive-liberty-mismatch', $pointer,
+ '(in source paragraph)',
+ $source_liberty,$ARROW, $inferior_liberty)
+ if (
+ all { $liberty_by_installable{$_} eq $inferior_liberty }
+ keys %liberty_by_installable
+ )
+ && (
+ none { $liberty_by_installable{$_} eq $source_liberty }
+ keys %liberty_by_installable
+ );
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Archive/NonFree/Autobuild.pm b/lib/Lintian/Check/Archive/NonFree/Autobuild.pm
new file mode 100644
index 0000000..939f0fc
--- /dev/null
+++ b/lib/Lintian/Check/Archive/NonFree/Autobuild.pm
@@ -0,0 +1,70 @@
+# archive/non-free/autobuild -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Archive::NonFree::Autobuild;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->is_non_free;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my $changes = $self->group->changes;
+
+ # source-only upload
+ if (defined $changes
+ && $changes->fields->value('Architecture') eq 'source') {
+
+ my $field = 'XS-Autobuild';
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('source-only-upload-to-non-free-without-autobuild',
+ $pointer, '(in the source paragraph)', $field)
+ if !$source_fields->declares($field)
+ || $source_fields->value($field) eq 'no';
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries.pm b/lib/Lintian/Check/Binaries.pm
new file mode 100644
index 0000000..9e71f25
--- /dev/null
+++ b/lib/Lintian/Check/Binaries.pm
@@ -0,0 +1,73 @@
+# binaries -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::Compare;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ my @KNOWN_STRIPPED_SECTION_NAMES = qw{.note .comment};
+
+ my @elf_sections = values %{$item->elf->{'SECTION-HEADERS'}};
+ my @have_section_names = map { $_->name } @elf_sections;
+
+ my $lc_name = List::Compare->new(\@have_section_names,
+ \@KNOWN_STRIPPED_SECTION_NAMES);
+
+ my @have_stripped_sections = $lc_name->get_intersection;
+
+ # appropriately stripped, but is it stripped enough?
+ if ( $item->file_type !~ m{ \b not [ ] stripped \b }x
+ && $item->name !~ m{^ (?:usr/)? lib/ (?: debug | profile ) / }x) {
+
+ $self->pointed_hint('binary-has-unneeded-section', $item->pointer, $_)
+ for @have_stripped_sections;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Architecture.pm b/lib/Lintian/Check/Binaries/Architecture.pm
new file mode 100644
index 0000000..009b1f5
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Architecture.pm
@@ -0,0 +1,60 @@
+# binaries/architecture -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Architecture;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ m{^ [^,]* \b ELF \b }x
+ || $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+
+ $self->pointed_hint('arch-independent-package-contains-binary-or-object',
+ $item->pointer)
+ if $architecture eq 'all';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Architecture/Other.pm b/lib/Lintian/Check/Binaries/Architecture/Other.pm
new file mode 100644
index 0000000..b40811f
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Architecture/Other.pm
@@ -0,0 +1,141 @@
+# binaries/architecture/other -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Architecture::Other;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Guile object files do not objdump/strip correctly, so exclude them
+# from a number of tests. (#918444)
+const my $GUILE_PATH_REGEX => qr{^usr/lib(?:/[^/]+)+/guile/[^/]+/.+\.go$};
+
+has ARCH_REGEX => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %arch_regex;
+
+ my $data = $self->data->load('binaries/arch-regex', qr/\s*\~\~/);
+ for my $architecture ($data->all) {
+
+ my $pattern = $data->value($architecture);
+ $arch_regex{$architecture} = qr{$pattern};
+ }
+
+ return \%arch_regex;
+ }
+);
+
+has ARCH_64BIT_EQUIVS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('binaries/arch-64bit-equivs',qr/\s*\=\>\s*/);
+ }
+);
+
+sub from_other_architecture {
+ my ($self, $item) = @_;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+
+ return 0
+ if $architecture eq 'all';
+
+ # If it matches the architecture regex, it is good
+ return 0
+ if exists $self->ARCH_REGEX->{$architecture}
+ && $item->file_type =~ $self->ARCH_REGEX->{$architecture};
+
+ # Special case - "old" multi-arch dirs
+ if ( $item->name =~ m{(?:^|/)lib(x?\d\d)/}
+ || $item->name =~ m{^emul/ia(\d\d)}) {
+
+ my $bus_width = $1;
+
+ return 0
+ if exists $self->ARCH_REGEX->{$bus_width}
+ && $item->file_type =~ $self->ARCH_REGEX->{$bus_width};
+ }
+
+ # Detached debug symbols could be for a biarch library.
+ return 0
+ if $item->name =~ m{^usr/lib/debug/\.build-id/};
+
+ # Guile binaries do not objdump/strip (etc.) correctly.
+ return 0
+ if $item->name =~ $GUILE_PATH_REGEX;
+
+ # Allow amd64 kernel modules to be installed on i386.
+ if ( $item->name =~ m{^lib/modules/}
+ && $self->ARCH_64BIT_EQUIVS->recognizes($architecture)) {
+
+ my $equivalent_64 = $self->ARCH_64BIT_EQUIVS->value($architecture);
+
+ return 0
+ if $item->file_type =~ $self->ARCH_REGEX->{$equivalent_64};
+ }
+
+ # Ignore i386 binaries in amd64 packages for right now.
+ return 0
+ if $architecture eq 'amd64'
+ && $item->file_type =~ $self->ARCH_REGEX->{i386};
+
+ return 1;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ $self->pointed_hint('binary-from-other-architecture', $item->pointer)
+ if $self->from_other_architecture($item);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Corrupted.pm b/lib/Lintian/Check/Binaries/Corrupted.pm
new file mode 100644
index 0000000..834ed31
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Corrupted.pm
@@ -0,0 +1,93 @@
+# binaries/corrupted -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Corrupted;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ $self->check_elf_issues($item);
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->check_elf_issues($item);
+
+ return;
+}
+
+sub check_elf_issues {
+ my ($self, $item) = @_;
+
+ return unless $item->is_elf;
+
+ for (uniq @{$item->elf->{ERRORS} // []}) {
+ $self->pointed_hint('elf-error',$item->pointer, $_)
+ unless (
+ m{In program headers: Unable to find program interpreter name}
+ and $item->name =~ m{^usr/lib/debug/});
+ }
+
+ $self->pointed_hint('elf-warning', $item->pointer, $_)
+ for uniq @{$item->elf->{WARNINGS} // []};
+
+ # static library
+ for my $member_name (keys %{$item->elf_by_member}) {
+
+ my $member_elf = $item->elf_by_member->{$member_name};
+
+ $self->pointed_hint('elf-error', $item->pointer, $member_name, $_)
+ for uniq @{$member_elf->{ERRORS} // []};
+
+ $self->pointed_hint('elf-warning', $item->pointer, $member_name, $_)
+ for uniq @{$member_elf->{WARNINGS} // []};
+ }
+
+ $self->pointed_hint('binary-with-bad-dynamic-table', $item->pointer)
+ if $item->elf->{'BAD-DYNAMIC-TABLE'}
+ && $item->name !~ m{^usr/lib/debug/};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/DebugSymbols.pm b/lib/Lintian/Check/Binaries/DebugSymbols.pm
new file mode 100644
index 0000000..4afe525
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/DebugSymbols.pm
@@ -0,0 +1,72 @@
+# binaries/debug-symbols -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::DebugSymbols;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Guile object files do not objdump/strip correctly, so exclude them
+# from a number of tests. (#918444)
+const my $GUILE_PATH_REGEX => qr{^usr/lib(?:/[^/]+)+/guile/[^/]+/.+\.go$};
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ # Is it an object file (which generally cannot be
+ # stripped), a kernel module, debugging symbols, or
+ # perhaps a debugging package?
+ $self->pointed_hint('unstripped-binary-or-object', $item->pointer)
+ if $item->file_type =~ m{ \b not [ ] stripped \b }x
+ && $item->name !~ m{ [.]k?o $}x
+ && $self->processable->name !~ m{ -dbg $}x
+ && $item->name !~ m{^ (?:usr/)? lib/debug/ }x
+ && $item->name !~ $GUILE_PATH_REGEX
+ && $item->name !~ m{ [.]gox $}x
+ && ( $item->file_type !~ m/executable/
+ || $item->strings !~ m{^ Caml1999X0[0-9][0-9] $}mx);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm b/lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm
new file mode 100644
index 0000000..b4f9a4f
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm
@@ -0,0 +1,86 @@
+# binaries/debug-symbols/detached -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::DebugSymbols::Detached;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::Compare;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ return
+ unless $item->file_type =~ m{ executable | shared [ ] object }x;
+
+ # Detached debugging symbols directly in /usr/lib/debug.
+ $self->pointed_hint('debug-symbols-directly-in-usr-lib-debug',
+ $item->pointer)
+ if $item->dirname eq 'usr/lib/debug/';
+
+ return
+ unless $item->name
+ =~ m{^ usr/lib/debug/ (?:lib\d*|s?bin|usr|opt|dev|emul|\.build-id) / }x;
+
+ $self->pointed_hint('debug-symbols-not-detached', $item->pointer)
+ if exists $item->elf->{NEEDED};
+
+ # Something other than detached debugging symbols in
+ # /usr/lib/debug paths.
+ my @KNOWN_DEBUG_SECTION_NAMES
+ = qw{.debug_line .zdebug_line .debug_str .zdebug_str};
+
+ my @elf_sections = values %{$item->elf->{'SECTION-HEADERS'}};
+ my @have_section_names = map { $_->name } @elf_sections;
+
+ my $lc_name
+ = List::Compare->new(\@have_section_names, \@KNOWN_DEBUG_SECTION_NAMES);
+
+ my @have_debug_sections = $lc_name->get_intersection;
+
+ $self->pointed_hint('debug-file-with-no-debug-symbols', $item->pointer)
+ unless @have_debug_sections;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Hardening.pm b/lib/Lintian/Check/Binaries/Hardening.pm
new file mode 100644
index 0000000..55e70ac
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Hardening.pm
@@ -0,0 +1,183 @@
+# binaries/hardening -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Hardening;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has HARDENED_FUNCTIONS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('binaries/hardened-functions');
+ }
+);
+
+has recommended_hardening_features => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %recommended_hardening_features;
+
+ my $hardening_buildflags = $self->data->hardening_buildflags;
+ my $architecture = $self->processable->fields->value('Architecture');
+
+ %recommended_hardening_features
+ = map { $_ => 1 }
+ @{$hardening_buildflags->recommended_features->{$architecture}}
+ if $architecture ne 'all';
+
+ return \%recommended_hardening_features;
+ }
+);
+
+has built_with_golang => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $built_with_golang = $self->processable->name =~ m/^golang-/;
+
+ my $source = $self->group->source;
+
+ $built_with_golang
+ = $source->relation('Build-Depends-All')
+ ->satisfies('golang-go | golang-any')
+ if defined $source;
+
+ return $built_with_golang;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my @elf_hardened;
+ my @elf_unhardened;
+
+ for my $symbol (@{$item->elf->{SYMBOLS}}) {
+
+ next
+ unless $symbol->section eq 'UND';
+
+ if ($symbol->name =~ /^__(\S+)_chk$/) {
+
+ my $vulnerable = $1;
+ push(@elf_hardened, $vulnerable)
+ if $self->HARDENED_FUNCTIONS->recognizes($vulnerable);
+
+ } else {
+
+ push(@elf_unhardened, $symbol->name)
+ if $self->HARDENED_FUNCTIONS->recognizes($symbol->name);
+ }
+ }
+
+ $self->pointed_hint('hardening-no-fortify-functions', $item->pointer)
+ if @elf_unhardened
+ && !@elf_hardened
+ && !$self->built_with_golang
+ && $self->recommended_hardening_features->{fortify};
+
+ for my $member_name (keys %{$item->elf_by_member}) {
+
+ my @member_hardened;
+ my @member_unhardened;
+
+ for my $symbol (@{$item->elf_by_member->{$member_name}{SYMBOLS}}) {
+
+ next
+ unless $symbol->section eq 'UND';
+
+ if ($symbol->name =~ /^__(\S+)_chk$/) {
+
+ my $vulnerable = $1;
+ push(@member_hardened, $vulnerable)
+ if $self->HARDENED_FUNCTIONS->recognizes($vulnerable);
+
+ } else {
+
+ push(@member_unhardened, $symbol->name)
+ if $self->HARDENED_FUNCTIONS->recognizes($symbol->name);
+ }
+ }
+
+ $self->pointed_hint('hardening-no-fortify-functions',
+ $item->pointer, $member_name)
+ if @member_unhardened
+ && !@member_hardened
+ && !$self->built_with_golang
+ && $self->recommended_hardening_features->{fortify};
+ }
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ return
+ unless $item->is_file;
+
+ return
+ if $item->file_type !~ m{^ [^,]* \b ELF \b }x
+ || $item->file_type !~ m{ \b executable | shared [ ] object \b }x;
+
+ # dynamically linked?
+ return
+ unless exists $item->elf->{NEEDED};
+
+ $self->pointed_hint('hardening-no-relro', $item->pointer)
+ if $self->recommended_hardening_features->{relro}
+ && !$self->built_with_golang
+ && !$item->elf->{PH}{RELRO};
+
+ $self->pointed_hint('hardening-no-bindnow', $item->pointer)
+ if $self->recommended_hardening_features->{bindnow}
+ && !$self->built_with_golang
+ && !exists $item->elf->{FLAGS_1}{NOW};
+
+ $self->pointed_hint('hardening-no-pie', $item->pointer)
+ if $self->recommended_hardening_features->{pie}
+ && !$self->built_with_golang
+ && $item->elf->{'ELF-HEADER'}{Type} =~ m{^ EXEC }x;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/LargeFileSupport.pm b/lib/Lintian/Check/Binaries/LargeFileSupport.pm
new file mode 100644
index 0000000..e64d727
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/LargeFileSupport.pm
@@ -0,0 +1,108 @@
+# binaries/large-file-support -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::LargeFileSupport;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has ARCH_REGEX => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %arch_regex;
+
+ my $data = $self->data->load('binaries/arch-regex', qr/\s*\~\~/);
+ for my $architecture ($data->all) {
+
+ my $pattern = $data->value($architecture);
+ $arch_regex{$architecture} = qr{$pattern};
+ }
+
+ return \%arch_regex;
+ }
+);
+
+has LFS_SYMBOLS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('binaries/lfs-symbols');
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # The LFS check only works reliably for ELF files due to the
+ # architecture regex.
+ return
+ unless $item->is_elf;
+
+ # Only 32bit ELF binaries can lack LFS.
+ return
+ unless $item->file_type =~ $self->ARCH_REGEX->{'32'};
+
+ return
+ if $item->name =~ m{^usr/lib/debug/};
+
+ my @unresolved_symbols;
+ for my $symbol (@{$item->elf->{SYMBOLS} // [] }) {
+
+ # ignore if defined in the binary
+ next
+ unless $symbol->section eq 'UND';
+
+ push(@unresolved_symbols, $symbol->name);
+ }
+
+ # Using a 32bit only interface call, some parts of the
+ # binary are built without LFS
+ $self->pointed_hint('binary-file-built-without-LFS-support',$item->pointer)
+ if any { $self->LFS_SYMBOLS->recognizes($_) } @unresolved_symbols;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Location.pm b/lib/Lintian/Check/Binaries/Location.pm
new file mode 100644
index 0000000..c207ae0
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Location.pm
@@ -0,0 +1,138 @@
+# binaries/location -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Location;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+const my %PATH_DIRECTORIES => map { $_ => 1 } qw(
+ bin/ sbin/ usr/bin/ usr/sbin/ usr/games/ );
+
+has DEB_HOST_MULTIARCH => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->architectures->deb_host_multiarch;
+ }
+);
+
+has gnu_triplet_pattern => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $gnu_triplet_pattern = $EMPTY;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+ my $madir = $self->DEB_HOST_MULTIARCH->{$architecture};
+
+ if (length $madir) {
+ $gnu_triplet_pattern = quotemeta $madir;
+ $gnu_triplet_pattern =~ s{^i386}{i[3-6]86};
+ }
+
+ return $gnu_triplet_pattern;
+ }
+);
+
+has ruby_triplet_pattern => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $ruby_triplet_pattern = $self->gnu_triplet_pattern;
+ $ruby_triplet_pattern =~ s{linux\\-gnu$}{linux};
+ $ruby_triplet_pattern =~ s{linux\\-gnu}{linux\\-};
+
+ return $ruby_triplet_pattern;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x
+ || $item->file_type =~ / \b current [ ] ar [ ] archive \b /x;
+
+ $self->pointed_hint('binary-in-etc', $item->pointer)
+ if $item->name =~ m{^etc/};
+
+ $self->pointed_hint('arch-dependent-file-in-usr-share', $item->pointer)
+ if $item->name =~ m{^usr/share/};
+
+ my $fields = $self->processable->fields;
+
+ my $architecture = $fields->value('Architecture');
+ my $multiarch = $fields->value('Multi-Arch') || 'no';
+
+ my $gnu_triplet_pattern = $self->gnu_triplet_pattern;
+ my $ruby_triplet_pattern = $self->ruby_triplet_pattern;
+
+ $self->pointed_hint('arch-dependent-file-not-in-arch-specific-directory',
+ $item->pointer)
+ if $multiarch eq 'same'
+ && length $gnu_triplet_pattern
+ && $item->name !~ m{\b$gnu_triplet_pattern(?:\b|_)}
+ && length $ruby_triplet_pattern
+ && $item->name !~ m{/$ruby_triplet_pattern/}
+ && $item->name !~ m{/java-\d+-openjdk-\Q$architecture\E/}
+ && $item->name !~ m{/[.]build-id/};
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ $self->pointed_hint('development-package-ships-elf-binary-in-path',
+ $item->pointer)
+ if exists $PATH_DIRECTORIES{$item->dirname}
+ && $fields->value('Section') =~ m{ (?:^|/) libdevel $}x
+ && $fields->value('Multi-Arch') ne 'foreign';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Obsolete/Crypt.pm b/lib/Lintian/Check/Binaries/Obsolete/Crypt.pm
new file mode 100644
index 0000000..8813d8b
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Obsolete/Crypt.pm
@@ -0,0 +1,90 @@
+# binaries/obsolete/crypt -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Obsolete::Crypt;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has OBSOLETE_CRYPT_FUNCTIONS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('binaries/obsolete-crypt-functions',
+ qr/\s*\|\|\s*/);
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ for my $symbol (@{$item->elf->{SYMBOLS} // []}) {
+
+ next
+ unless $symbol->section eq 'UND';
+
+ next
+ unless $self->OBSOLETE_CRYPT_FUNCTIONS->recognizes($symbol->name);
+
+ my $tag = $self->OBSOLETE_CRYPT_FUNCTIONS->value($symbol->name);
+
+ $self->pointed_hint($tag, $item->pointer, $symbol->name);
+ }
+
+ for my $member_name (keys %{$item->elf_by_member}) {
+
+ for
+ my $symbol (@{$item->elf_by_member->{$member_name}{SYMBOLS} // []}) {
+
+ next
+ unless $symbol->section eq 'UND';
+
+ next
+ unless $self->OBSOLETE_CRYPT_FUNCTIONS->recognizes(
+ $symbol->name);
+
+ my $tag = $self->OBSOLETE_CRYPT_FUNCTIONS->value($symbol->name);
+
+ $self->pointed_hint($tag, $item->pointer, "($member_name)",
+ $symbol->name);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Prerequisites.pm b/lib/Lintian/Check/Binaries/Prerequisites.pm
new file mode 100644
index 0000000..cdc5868
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Prerequisites.pm
@@ -0,0 +1,214 @@
+# binaries/prerequisites -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Prerequisites;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none uniq);
+
+const my $SPACE => q{ };
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+# Guile object files do not objdump/strip correctly, so exclude them
+# from a number of tests. (#918444)
+const my $GUILE_PATH_REGEX => qr{^usr/lib(?:/[^/]+)+/guile/[^/]+/.+\.go$};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has built_with_octave => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $built_with_octave = $self->processable->name =~ m/^octave-/;
+
+ my $source = $self->group->source;
+
+ $built_with_octave
+ = $source->relation('Build-Depends')->satisfies('dh-octave:any')
+ if defined $source;
+
+ return $built_with_octave;
+ }
+);
+
+has files_by_library => (is => 'rw', default => sub { {} });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ return
+ unless $item->file_type =~ m{ executable | shared [ ] object }x;
+
+ my $is_shared = $item->file_type =~ m/(shared object|pie executable)/;
+
+ for my $library (@{$item->elf->{NEEDED} // [] }) {
+
+ $self->files_by_library->{$library} //= [];
+ push(@{$self->files_by_library->{$library}}, $item->name);
+ }
+
+ # Some exceptions: kernel modules, syslinux modules, detached
+ # debugging information and the dynamic loader (which itself
+ # has no dependencies).
+ $self->pointed_hint('shared-library-lacks-prerequisites', $item->pointer)
+ if $is_shared
+ && !@{$item->elf->{NEEDED} // []}
+ && $item->name !~ m{^boot/modules/}
+ && $item->name !~ m{^lib/modules/}
+ && $item->name !~ m{^usr/lib/debug/}
+ && $item->name !~ m{\.(?:[ce]32|e64)$}
+ && $item->name !~ m{^usr/lib/jvm/.*\.debuginfo$}
+ && $item->name !~ $GUILE_PATH_REGEX
+ && $item->name !~ m{
+ ^lib(?:|32|x32|64)/
+ (?:[-\w/]+/)?
+ ld-[\d.]+\.so$
+ }xsm;
+
+ my $depends = $self->processable->relation('strong');
+
+ $self->pointed_hint('undeclared-elf-prerequisites', $item->pointer,
+ $LEFT_PARENTHESIS
+ . join($SPACE, sort +uniq @{$item->elf->{NEEDED} // []})
+ . $RIGHT_PARENTHESIS)
+ if @{$item->elf->{NEEDED} // [] }
+ && $depends->is_empty;
+
+ # If there is no libc dependency, then it is most likely a
+ # bug. The major exception is that some C++ libraries,
+ # but these tend to link against libstdc++ instead. (see
+ # #719806)
+ my $linked_with_libc
+ = any { m{^ libc[.]so[.] }x } @{$item->elf->{NEEDED} // []};
+
+ $self->pointed_hint('library-not-linked-against-libc', $item->pointer)
+ if !$linked_with_libc
+ && $is_shared
+ && @{$item->elf->{NEEDED} // [] }
+ && (none { /^libc[.]so[.]/ } @{$item->elf->{NEEDED} // [] })
+ && $item->name !~ m{/libc\b}
+ && (!$self->built_with_octave
+ || $item->name !~ m/\.(?:oct|mex)$/);
+
+ $self->pointed_hint('program-not-linked-against-libc', $item->pointer)
+ if !$linked_with_libc
+ && !$is_shared
+ && @{$item->elf->{NEEDED} // [] }
+ && (none { /^libstdc[+][+][.]so[.]/ }@{$item->elf->{NEEDED} // [] })
+ && !$self->built_with_octave;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $depends = $self->processable->relation('strong');
+ return
+ if $depends->is_empty;
+
+ my %libc_files;
+ for my $library (keys %{$self->files_by_library}) {
+
+ # Match libcXX or libcXX-*, but not libc3p0.
+ next
+ unless $library =~ m{^ libc [.] so [.] (\d+ .*) $}x;
+
+ my $package = "libc$1";
+
+ $libc_files{$package} //= [];
+ push(@{$libc_files{$package}}, @{$self->files_by_library->{$library}});
+ }
+
+ for my $package (keys %libc_files) {
+
+ next
+ if $depends->matches(qr/^\Q$package\E\b/);
+
+ my @sorted = sort +uniq @{$libc_files{$package}};
+
+ my $context = 'needed by ' . $sorted[0];
+ $context .= ' and ' . (scalar @sorted - 1) . ' others'
+ if @sorted > 1;
+
+ $self->hint('missing-dependency-on-libc', $context)
+ unless $self->processable->name =~ m{^ libc [\d.]+ (?:-|\z) }x;
+ }
+
+ my %libcxx_files;
+ for my $library (keys %{$self->files_by_library}) {
+
+ # Match libstdc++XX or libcstdc++XX-*
+ next
+ unless $library =~ m{^ libstdc[+][+] [.] so [.] (\d+) $}xsm;
+
+ my $package = "libstdc++$1";
+
+ $libcxx_files{$package} //= [];
+ push(@{$libcxx_files{$package}},
+ @{$self->files_by_library->{$library}});
+ }
+
+ for my $package (keys %libcxx_files) {
+
+ next
+ if $depends->matches(qr/^\Q$package\E\b/);
+
+ my @sorted = sort +uniq @{$libcxx_files{$package}};
+
+ my $context = 'needed by ' . $sorted[0];
+ $context .= ' and ' . (scalar @sorted - 1) . ' others'
+ if @sorted > 1;
+
+ $self->hint('missing-dependency-on-libstdc++', $context);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm b/lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm
new file mode 100644
index 0000000..c1ecfc3
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm
@@ -0,0 +1,107 @@
+# binaries/prerequisites/numpy -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Prerequisites::Numpy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $NUMPY_REGEX => qr{
+ \Qmodule compiled against ABI version \E (?:0x)?%x
+ \Q but this version of numpy is \E (?:0x)?%x
+}x;
+
+has uses_numpy_c_abi => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ if $item->file_type !~ m{^ [^,]* \b ELF \b }x
+ || $item->file_type !~ m{ \b executable | shared [ ] object \b }x;
+
+ # Python extension using Numpy C ABI?
+ if ( $item->name=~ m{^usr/lib/(?:pyshared/)?python2\.\d+/.*(?<!_d)\.so$}
+ || $item->name
+ =~ m{^ usr/lib/python3(?:[.]\d+)? / \S+ [.]cpython- \d+ - \S+ [.]so $}x
+ ){
+ $self->uses_numpy_c_abi(1)
+ if $item->strings =~ / numpy /msx
+ && $item->strings =~ $NUMPY_REGEX;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ my $depends = $self->processable->relation('strong');
+
+ # Check for dependency on python3-numpy-abiN dependency (or strict
+ # versioned dependency on python3-numpy)
+ # We do not allow alternatives as it would mostly likely
+ # defeat the purpose of this relation. Also, we do not allow
+ # versions for -abi as it is a virtual package.
+ $self->hint('missing-dependency-on-numpy-abi')
+ if $self->uses_numpy_c_abi
+ && !$depends->matches(qr/^python3?-numpy-abi\d+$/,
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL)
+ && (
+ !$depends->matches(
+ qr/^python3-numpy \(>[>=][^\|]+$/,
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL
+ )
+ || !$depends->matches(
+ qr/^python3-numpy \(<[<=][^\|]+$/,
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL
+ )
+ )
+ && $self->processable->name !~ m{\A python3?-numpy \Z}xsm;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Prerequisites/Perl.pm b/lib/Lintian/Check/Binaries/Prerequisites/Perl.pm
new file mode 100644
index 0000000..a105d25
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Prerequisites/Perl.pm
@@ -0,0 +1,81 @@
+# binaries/prerequisites/perl -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Prerequisites::Perl;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has has_perl_lib => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ if $item->file_type !~ m{^ [^,]* \b ELF \b }x
+ || $item->file_type !~ m{ \b executable | shared [ ] object \b }x;
+
+ $self->has_perl_lib(1)
+ if $item->name =~ m{^ usr/lib/ (?:[^/]+/)? perl5/ .* [.]so $}x;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ my $depends = $self->processable->relation('strong');
+
+ # It is a virtual package, so no version is allowed and
+ # alternatives probably does not make sense here either.
+ $self->hint('missing-dependency-on-perlapi')
+ if $self->has_perl_lib
+ && !$depends->matches(
+ qr/^perlapi-[-\w.]+(?:\s*\[[^\]]+\])?$/,
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL
+ );
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Prerequisites/Php.pm b/lib/Lintian/Check/Binaries/Prerequisites/Php.pm
new file mode 100644
index 0000000..f4f9634
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Prerequisites/Php.pm
@@ -0,0 +1,80 @@
+# binaries/prerequisites/php -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Prerequisites::Php;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has has_php_ext => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ if $item->file_type !~ m{^ [^,]* \b ELF \b }x
+ || $item->file_type !~ m{ \b executable | shared [ ] object \b }x;
+
+ # PHP extension?
+ $self->has_php_ext(1)
+ if $item->name =~ m{^usr/lib/php\d/.*\.so(?:\.\d+)*$};
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ my $depends = $self->processable->relation('strong');
+
+ # It is a virtual package, so no version is allowed and
+ # alternatives probably does not make sense here either.
+ $self->hint('missing-dependency-on-phpapi')
+ if $self->has_php_ext
+ && !$depends->matches(qr/^phpapi-[\d\w+]+$/,
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Profiling.pm b/lib/Lintian/Check/Binaries/Profiling.pm
new file mode 100644
index 0000000..4b52937
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Profiling.pm
@@ -0,0 +1,73 @@
+# binaries/profiling -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Profiling;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+
+ my $is_profiled = 0;
+
+ for my $symbol (@{$item->elf->{SYMBOLS} // [] }) {
+
+ # According to the binutils documentation[1], the profiling symbol
+ # can be named "mcount", "_mcount" or even "__mcount".
+ # [1] http://sourceware.org/binutils/docs/gprof/Implementation.html
+ $is_profiled = 1
+ if $symbol->version =~ /^GLIBC_.*/
+ && $symbol->name =~ m{\A _?+ _?+ (gnu_)?+mcount(_nc)?+ \Z}xsm
+ && ($symbol->section eq 'UND' || $symbol->section eq '.text');
+
+ # This code was used to detect profiled code in Wheezy and earlier
+ $is_profiled = 1
+ if $symbol->section eq '.text'
+ && $symbol->version eq 'Base'
+ && $symbol->name eq '__gmon_start__'
+ && $architecture ne 'hppa';
+ }
+
+ $self->pointed_hint('binary-compiled-with-profiling-enabled',
+ $item->pointer)
+ if $is_profiled;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Rpath.pm b/lib/Lintian/Check/Binaries/Rpath.pm
new file mode 100644
index 0000000..a4ecb93
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Rpath.pm
@@ -0,0 +1,145 @@
+# binaries/rpath -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Rpath;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Spec;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SLASH => q{/};
+
+has DEB_HOST_MULTIARCH => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->architectures->deb_host_multiarch;
+ }
+);
+
+has multiarch_component => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+ my $multiarch_component = $self->DEB_HOST_MULTIARCH->{$architecture};
+
+ return $multiarch_component;
+ }
+);
+
+has private_folders => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @lib_folders = qw{lib};
+
+ push(@lib_folders,
+ map { $_ . $SLASH . $self->multiarch_component } @lib_folders)
+ if length $self->multiarch_component;
+
+ my @usrlib_folders = qw{usr/lib};
+
+ push(@usrlib_folders,
+ map { $_ . $SLASH . $self->multiarch_component } @usrlib_folders)
+ if length $self->multiarch_component;
+
+ my @game_folders = map { "$_/games" } @usrlib_folders;
+
+ my @private_folders
+ = map { $_ . $SLASH . $self->processable->source_name }
+ (@lib_folders, @usrlib_folders, @game_folders);
+
+ return \@private_folders;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ for my $section (qw{RPATH RUNPATH}) {
+
+ my @rpaths = keys %{$item->elf->{$section} // {}};
+
+ my @no_origin = grep { !m{^ \$ \{? ORIGIN \}? }x } @rpaths;
+
+ my @canonical = map { File::Spec->canonpath($_) } @no_origin;
+
+ my @custom;
+ for my $folder (@canonical) {
+
+ # for shipped folders, would have to disallow system locations
+ next
+ if any { $folder =~ m{^ / \Q$_\E }x } @{$self->private_folders};
+
+ # GHC in Debian uses a scheme for RPATH (#914873)
+ next
+ if $folder =~ m{^ /usr/lib/ghc (?: / | $ ) }x;
+
+ push(@custom, $folder);
+ }
+
+ my @absolute = grep { m{^ / }x } @custom;
+
+ $self->pointed_hint('custom-library-search-path',
+ $item->pointer, $section, $_)
+ for @absolute;
+
+ my @relative = grep { m{^ [^/] }x } @custom;
+
+ $self->pointed_hint('relative-library-search-path',
+ $item->pointer, $section, $_)
+ for @relative;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Spelling.pm b/lib/Lintian/Check/Binaries/Spelling.pm
new file mode 100644
index 0000000..38a2529
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Spelling.pm
@@ -0,0 +1,86 @@
+# binaries/spelling -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Spelling;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has BINARY_SPELLING_EXCEPTIONS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('binaries/spelling-exceptions',qr/\s+/);
+ }
+);
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $item, @orig_args) = @_;
+
+ return sub {
+
+ my $pointer = $item->pointer($.);
+
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ my @acceptable = (
+ @{ $self->group->spelling_exceptions },
+ $self->BINARY_SPELLING_EXCEPTIONS->all
+ );
+
+ my $tag_emitter
+ = $self->spelling_tag_emitter('spelling-error-in-binary', $item);
+
+ check_spelling($self->data, $item->strings, \@acceptable, $tag_emitter, 0);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Binaries/Static.pm b/lib/Lintian/Check/Binaries/Static.pm
new file mode 100644
index 0000000..47eafb8
--- /dev/null
+++ b/lib/Lintian/Check/Binaries/Static.pm
@@ -0,0 +1,100 @@
+# binaries/static -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Binaries::Static;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has built_with_golang => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $built_with_golang = $self->processable->name =~ m/^golang-/;
+
+ my $source = $self->group->source;
+
+ $built_with_golang
+ = $source->relation('Build-Depends-All')
+ ->satisfies('golang-go | golang-any')
+ if defined $source;
+
+ return $built_with_golang;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ return
+ unless $item->file_type =~ m{ executable | shared [ ] object }x;
+
+ my $is_shared = $item->file_type =~ m/(shared object|pie executable)/;
+
+ # Some exceptions: files in /boot, /usr/lib/debug/*,
+ # named *-static or *.static, or *-static as
+ # package-name.
+ # Binaries built by the Go compiler are statically
+ # linked by default.
+ # klibc binaries appear to be static.
+ # Location of debugging symbols.
+ # ldconfig must be static.
+ $self->pointed_hint('statically-linked-binary', $item->pointer)
+ if !$is_shared
+ && !exists $item->elf->{NEEDED}
+ && $item->name !~ m{^boot/}
+ && $item->name !~ /[\.-]static$/
+ && $self->processable->name !~ /-static$/
+ && !$self->built_with_golang
+ && (!exists $item->elf->{INTERP}
+ || $item->elf->{INTERP} !~ m{/lib/klibc-\S+\.so})
+ && $item->name !~ m{^usr/lib/debug/}
+ && $item->name ne 'sbin/ldconfig';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/BuildSystems/Automake.pm b/lib/Lintian/Check/BuildSystems/Automake.pm
new file mode 100644
index 0000000..07a7d6d
--- /dev/null
+++ b/lib/Lintian/Check/BuildSystems/Automake.pm
@@ -0,0 +1,54 @@
+# build-systems/automake -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2013 Gautier Minster
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::BuildSystems::Automake;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ # automake probably isn't used without a Makefile.am
+ my $makefile = $self->processable->patched->lookup('Makefile.am');
+ return
+ unless defined $makefile;
+
+ my $configure_in = $self->processable->patched->lookup('configure.in');
+
+ $self->pointed_hint('deprecated-configure-filename',$configure_in->pointer)
+ if defined $configure_in;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/BuildSystems/Autotools.pm b/lib/Lintian/Check/BuildSystems/Autotools.pm
new file mode 100644
index 0000000..cf40183
--- /dev/null
+++ b/lib/Lintian/Check/BuildSystems/Autotools.pm
@@ -0,0 +1,88 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::BuildSystems::Autotools;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ if ( $item->name =~ /configure\.(in|ac)$/
+ && $item->is_open_ok) {
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ if $line =~ m{^ \s* dnl }x;
+
+ if ($line
+ =~ m{ (AC_PATH_PROG) \s* [(] [^,]+ , \s* \[? pkg-config \]? \s* , }x
+ ){
+
+ my $macro = $1;
+ $self->pointed_hint(
+ 'autotools-pkg-config-macro-not-cross-compilation-safe',
+ $item->pointer($position), $macro);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ # Tests of autotools files are a special case. Ignore
+ # debian/config.cache as anyone doing that probably knows what
+ # they're doing and is using it as part of the build.
+ $self->pointed_hint('configure-generated-file-in-source', $item->pointer)
+ if $item->basename =~ m{\A config.(?:cache|log|status) \Z}xsm
+ && $item->name !~ m{^ debian/ }sx;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm b/lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm
new file mode 100644
index 0000000..3f0865a
--- /dev/null
+++ b/lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm
@@ -0,0 +1,99 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::BuildSystems::Autotools::Libtool;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $ACCEPTABLE_LIBTOOL_MAJOR => 5;
+const my $ACCEPTABLE_LIBTOOL_MINOR => 2;
+const my $ACCEPTABLE_LIBTOOL_DEBIAN => 2;
+
+# Check if the package build-depends on autotools-dev, automake,
+# or libtool.
+my $LIBTOOL = Lintian::Relation->new->load('libtool | dh-autoreconf');
+has libtool_in_build_depends => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->processable->relation('Build-Depends-All')
+ ->satisfies($LIBTOOL);
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('ancient-libtool', $item->pointer)
+ if $item->basename eq 'ltconfig'
+ && $item->name !~ m{^ debian/ }sx
+ && !$self->libtool_in_build_depends;
+
+ if ( $item->basename eq 'ltmain.sh'
+ && $item->name !~ m{^ debian/ }sx
+ && !$self->libtool_in_build_depends) {
+
+ if ($item->bytes =~ /^VERSION=[\"\']?(1\.(\d)\.(\d+)(?:-(\d))?)/m) {
+ my ($version, $major, $minor, $debian)=($1, $2, $3, $4);
+
+ $debian //= 0;
+
+ $self->pointed_hint('ancient-libtool', $item->pointer, $version)
+ if $major < $ACCEPTABLE_LIBTOOL_MAJOR
+ || (
+ $major == $ACCEPTABLE_LIBTOOL_MAJOR
+ && (
+ $minor < $ACCEPTABLE_LIBTOOL_MINOR
+ || ( $minor == $ACCEPTABLE_LIBTOOL_MINOR
+ && $debian < $ACCEPTABLE_LIBTOOL_DEBIAN)
+ )
+ );
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/BuildSystems/Cmake.pm b/lib/Lintian/Check/BuildSystems/Cmake.pm
new file mode 100644
index 0000000..0dfaf2c
--- /dev/null
+++ b/lib/Lintian/Check/BuildSystems/Cmake.pm
@@ -0,0 +1,73 @@
+# build-systems/cmake -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::BuildSystems::Cmake;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # Check for CMake cache files. These embed the source path and hence
+ # will cause FTBFS on buildds, so they should never be present
+ $self->pointed_hint('source-contains-cmake-cache-file', $item->pointer)
+ if $item->basename eq 'CMakeCache.txt';
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # /usr/share/cmake-*
+ $self->pointed_hint('package-contains-cmake-private-file', $item->pointer)
+ if $item->name =~ m{^ usr/share/cmake- \d+ [.] \d+ / }x
+ && $self->processable->source_name ne 'cmake';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm b/lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm
new file mode 100644
index 0000000..7d54b79
--- /dev/null
+++ b/lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm
@@ -0,0 +1,80 @@
+# build-systems/debhelper/maintainer-script/token -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::BuildSystems::Debhelper::MaintainerScript::Token;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ unless $line =~ m{( [#] DEBHELPER [#] )}x;
+
+ my $token = $1;
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('maintainer-script-has-unexpanded-debhelper-token',
+ $pointer, $token);
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm b/lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm
new file mode 100644
index 0000000..7431c41
--- /dev/null
+++ b/lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm
@@ -0,0 +1,94 @@
+# build-systems/libtool/la-file -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::BuildSystems::Libtool::LaFile;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SLASH => q{/};
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $item->name !~ /[.]la$/ || length $item->link;
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ if ($line =~ /^ libdir=' (.+) ' $/x) {
+
+ my $own_location = $1;
+ $own_location =~ s{^/+}{};
+ $own_location =~ s{/*$}{/};
+
+ # python-central is a special case since the
+ # libraries are moved at install time.
+ next
+ if $own_location
+ =~ m{^ usr/lib/python [\d.]+ / (?:site|dist)-packages / }x
+ && $item->dirname =~ m{^ usr/share/pyshared/ }x;
+
+ $self->pointed_hint(
+ 'incorrect-libdir-in-la-file',
+ $item->pointer($position),
+ "$own_location != " . $item->dirname
+ ) unless $own_location eq $item->dirname;
+
+ }
+
+ if ($line =~ /^ dependency_libs=' (.+) ' $/x){
+
+ my $prerequisites = $1;
+
+ $self->pointed_hint(
+ 'non-empty-dependency_libs-in-la-file',
+ $item->pointer($position),
+ $prerequisites
+ );
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/BuildSystems/Waf.pm b/lib/Lintian/Check/BuildSystems/Waf.pm
new file mode 100644
index 0000000..4825a11
--- /dev/null
+++ b/lib/Lintian/Check/BuildSystems/Waf.pm
@@ -0,0 +1,87 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::BuildSystems::Waf;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->basename =~ m{ \b waf $}x;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $marker = 0;
+
+ while (my $line = <$fd>) {
+
+ next
+ unless $line =~ m/^#/;
+
+ if ($marker && $line =~ m/^#BZ[h0][0-9]/) {
+
+ # waf is not allowed
+ $self->pointed_hint('source-contains-waf-binary', $item->pointer);
+ last;
+ }
+
+ $marker = 1
+ if $line =~ m/^#==>/;
+
+ # We could probably stop here, but just in case
+ $marker = 0
+ if $line =~ m/^#<==/;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/ChangesFile.pm b/lib/Lintian/Check/ChangesFile.pm
new file mode 100644
index 0000000..617de64
--- /dev/null
+++ b/lib/Lintian/Check/ChangesFile.pm
@@ -0,0 +1,121 @@
+# changes-file -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+#
+# This program is free software. It is distributed under the terms of
+# the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any
+# later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::ChangesFile;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(uniq);
+use Path::Tiny;
+
+use Lintian::Util qw(get_file_checksum);
+
+const my $NOT_EQUALS => q{!=};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub changes {
+ my ($self) = @_;
+
+ my %count_by_algorithm;
+
+ for my $basename (keys %{$self->processable->files}) {
+
+ my $details = $self->processable->files->{$basename};
+
+ $self->hint('bad-section-in-changes-file', $basename,
+ $details->{section})
+ if $details->{section} eq 'non-free'
+ || $details->{section} eq 'contrib';
+
+ # take from location near input file
+ my $physical_path
+ = path($self->processable->path)->sibling($basename)->stringify;
+ my $actual_size = -s $physical_path;
+
+ # check size
+ $self->hint('file-size-mismatch-in-changes-file',
+ $basename, $details->{size}, $NOT_EQUALS, $actual_size)
+ unless $details->{size} == $actual_size;
+
+ for my $algorithm (qw(Md5 Sha1 Sha256)) {
+
+ my $checksum_info = $details->{checksums}{$algorithm};
+ next
+ unless defined $checksum_info;
+
+ $self->hint('file-size-mismatch-in-changes-file',
+ $basename,$details->{size}, $NOT_EQUALS,
+ $checksum_info->{filesize})
+ unless $details->{size} == $checksum_info->{filesize};
+
+ my $actual_checksum= get_file_checksum($algorithm, $physical_path);
+
+ $self->hint('checksum-mismatch-in-changes-file',
+ "Checksum-$algorithm", $basename)
+ unless $checksum_info->{sum} eq $actual_checksum;
+
+ ++$count_by_algorithm{$algorithm};
+ }
+ }
+
+ my @installables= grep { m{ [.]deb $}x } keys %{$self->processable->files};
+ my @installable_names = map { m{^ ([^_]+) _ }x } @installables;
+ my @stems = uniq map { m{^ (.+) -dbg (?:sym) $}x } @installable_names;
+
+ for my $stem (@stems) {
+
+ my @conflicting = ("$stem-dbg", "$stem-dbgsym");
+
+ my $lc = List::Compare->new(\@conflicting, \@installable_names);
+ $self->hint('package-builds-dbg-and-dbgsym-variants',
+ (sort @conflicting))
+ if $lc->is_LsubsetR;
+ }
+
+ # Check that we have a consistent number of checksums and files
+ for my $algorithm (keys %count_by_algorithm) {
+
+ my $actual_count = $count_by_algorithm{$algorithm};
+ my $expected_count = scalar keys %{$self->processable->files};
+
+ $self->hint('checksum-count-mismatch-in-changes-file',
+"$actual_count Checksum-$algorithm checksums != $expected_count files"
+ ) if $actual_count != $expected_count;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Conffiles.pm b/lib/Lintian/Check/Conffiles.pm
new file mode 100644
index 0000000..076c17f
--- /dev/null
+++ b/lib/Lintian/Check/Conffiles.pm
@@ -0,0 +1,136 @@
+# conffiles -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2017 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Conffiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any none);
+use Path::Tiny;
+
+const my $SPACE => q{ };
+
+const my @KNOWN_INSTRUCTIONS => qw(remove-on-upgrade);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $self->processable->type =~ 'udeb';
+
+ my $declared_conffiles = $self->processable->declared_conffiles;
+
+ unless ($item->is_file) {
+ $self->pointed_hint('conffile-has-bad-file-type', $item->pointer)
+ if $declared_conffiles->is_known($item->name);
+ return;
+ }
+
+ # files /etc must be conffiles, with some exceptions).
+ $self->pointed_hint('file-in-etc-not-marked-as-conffile',$item->pointer)
+ if $item->name =~ m{^etc/}
+ && !$declared_conffiles->is_known($item->name)
+ && $item->name !~ m{/README$}
+ && $item->name !~ m{^ etc/init[.]d/ (?: skeleton | rc S? ) $}x;
+
+ return;
+}
+
+sub binary {
+ my ($self) = @_;
+
+ my $declared_conffiles = $self->processable->declared_conffiles;
+ for my $relative ($declared_conffiles->all) {
+
+ my $item = $self->processable->conffiles_item;
+
+ my @entries = @{$declared_conffiles->by_file->{$relative}};
+
+ my @positions = map { $_->position } @entries;
+ my $lines = join($SPACE, (sort { $a <=> $b } @positions));
+
+ $self->pointed_hint('duplicate-conffile', $item->pointer,
+ $relative, "(lines $lines)")
+ if @entries > 1;
+
+ for my $entry (@entries) {
+
+ my $conffiles_item = $self->processable->conffiles_item;
+ my $pointer = $conffiles_item->pointer($entry->position);
+
+ $self->pointed_hint('relative-conffile', $pointer,$relative)
+ if $entry->is_relative;
+
+ $self->pointed_hint('file-in-etc-rc.d-marked-as-conffile',
+ $pointer, $relative)
+ if $relative =~ m{^etc/rc.\.d/};
+
+ $self->pointed_hint('file-in-usr-marked-as-conffile',
+ $pointer, $relative)
+ if $relative =~ m{^usr/};
+
+ $self->pointed_hint('non-etc-file-marked-as-conffile',
+ $pointer, $relative)
+ unless $relative =~ m{^etc/};
+
+ my @instructions = @{$entry->instructions};
+
+ my $instruction_lc
+ = List::Compare->new(\@instructions, \@KNOWN_INSTRUCTIONS);
+ my @unknown = $instruction_lc->get_Lonly;
+
+ $self->pointed_hint('unknown-conffile-instruction', $pointer, $_)
+ for @unknown;
+
+ my $should_exist= none { $_ eq 'remove-on-upgrade' } @instructions;
+ my $may_not_exist= any { $_ eq 'remove-on-upgrade' } @instructions;
+
+ my $shipped = $self->processable->installed->lookup($relative);
+
+ $self->pointed_hint('missing-conffile', $pointer, $relative)
+ if $should_exist && !defined $shipped;
+
+ $self->pointed_hint('unexpected-conffile', $pointer, $relative)
+ if $may_not_exist && defined $shipped;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/ContinuousIntegration/Salsa.pm b/lib/Lintian/Check/ContinuousIntegration/Salsa.pm
new file mode 100644
index 0000000..3faa978
--- /dev/null
+++ b/lib/Lintian/Check/ContinuousIntegration/Salsa.pm
@@ -0,0 +1,103 @@
+# continuous-integration/salsa -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::ContinuousIntegration::Salsa;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Data::DPath qw(dpath);
+use List::SomeUtils qw(any);
+use Scalar::Util qw(reftype);
+use YAML::XS qw(LoadFile);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# ci is configured in gitlab and can be located anywere
+# https://salsa.debian.org/salsa-ci-team/pipeline/-/issues/86
+my @KNOWN_LOCATIONS = qw(
+ debian/salsa-ci.yml
+ debian/gitlab-ci.yml
+ gitlab-ci.yml
+ .gitlab-ci.yml
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless any { $item->name eq $_ } @KNOWN_LOCATIONS;
+
+ $self->pointed_hint('specification', $item->pointer);
+
+ return
+ unless $item->is_open_ok;
+
+ my $yaml = LoadFile($item->unpacked_path);
+ return
+ unless defined $yaml;
+
+# traditionally examined via codesearch
+# https://codesearch.debian.net/search?q=salsa-ci-team%2Fpipeline%2Fraw%2Fmaster%2Fsalsa-ci.yml&literal=1
+ my @items = dpath('//include')->match($yaml);
+
+ my @includes;
+ for my $item (@items) {
+
+ my $item_type = reftype $item;
+
+ if (!length $item_type) {
+ push(@includes, $item);
+
+ } elsif ($item_type eq 'ARRAY') {
+ for my $element (@{$item}) {
+
+ my $element_type = reftype $element;
+ if (!length $element_type) {
+ push(@includes, $element);
+
+ } elsif ($element_type eq 'HASH') {
+ # new Gitlab style with desciptors
+ push(@includes, $element->{file})
+ if exists $element->{file};
+ }
+ }
+ }
+ }
+
+ $self->pointed_hint('include', $item->pointer, $_) for @includes;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/ControlFiles.pm b/lib/Lintian/Check/ControlFiles.pm
new file mode 100644
index 0000000..d0c44a2
--- /dev/null
+++ b/lib/Lintian/Check/ControlFiles.pm
@@ -0,0 +1,132 @@
+# control-files -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2017 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::ControlFiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+const my $WIDELY_EXECUTABLE => oct(111);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has ships_ctrl_script => (is => 'rw', default => 0);
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ my $type = $self->processable->type;
+ my $processable = $self->processable;
+
+ my $DEB_PERMISSIONS
+ = $self->data->load('control-files/deb-permissions',qr/\s+/);
+ my $UDEB_PERMISSIONS
+ = $self->data->load('control-files/udeb-permissions',qr/\s+/);
+
+ my $ctrl = $type eq 'udeb' ? $UDEB_PERMISSIONS : $DEB_PERMISSIONS;
+ my $ctrl_alt = $type eq 'udeb' ? $DEB_PERMISSIONS : $UDEB_PERMISSIONS;
+
+ # the control.tar.gz should only contain files (and the "root"
+ # dir, but that is excluded from the index)
+ if (!$item->is_regular_file) {
+
+ $self->pointed_hint('control-file-is-not-a-file', $item->pointer);
+ # Doing further checks is probably not going to yield anything
+ # remotely useful.
+ return;
+ }
+
+ # valid control file?
+ unless ($ctrl->recognizes($item->name)) {
+
+ if ($ctrl_alt->recognizes($item->name)) {
+ $self->pointed_hint('not-allowed-control-file', $item->pointer);
+
+ } else {
+ $self->pointed_hint('unknown-control-file', $item->pointer);
+ }
+
+ return;
+ }
+
+ my $experm = oct($ctrl->value($item->name));
+
+ $self->pointed_hint('control-file-is-empty', $item->pointer)
+ if $item->size == 0
+ && $item->basename ne 'md5sums';
+
+ # skip `control' control file (that's an exception: dpkg
+ # doesn't care and this file isn't installed on the systems
+ # anyways)
+ return
+ if $item->name eq 'control';
+
+ my $operm = $item->operm;
+ if ($item->is_executable || $experm & $WIDELY_EXECUTABLE) {
+
+ $self->ships_ctrl_script(1);
+ $self->pointed_hint('ctrl-script', $item->pointer);
+ }
+
+ # correct permissions?
+ unless ($operm == $experm) {
+
+ $self->pointed_hint('control-file-has-bad-permissions',
+ $item->pointer,sprintf('%04o != %04o', $operm, $experm));
+ }
+
+ # correct owner?
+ unless ($item->identity eq 'root/root' || $item->identity eq '0/0') {
+
+ $self->pointed_hint('control-file-has-bad-owner',$item->pointer,
+ $item->identity,'!= root/root (or 0/0)');
+ }
+
+ # for other maintainer scripts checks, see the scripts check
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint('no-ctrl-scripts')
+ unless $self->ships_ctrl_script;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Cron.pm b/lib/Lintian/Check/Cron.pm
new file mode 100644
index 0000000..cca2420
--- /dev/null
+++ b/lib/Lintian/Check/Cron.pm
@@ -0,0 +1,67 @@
+# cron -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Cron;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $READ_WRITE_PERMISSIONS => oct(644);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^ etc/cron }x;
+
+ # /etc/cron.daily, etc.
+ # NB: cron ships ".placeholder" files, which shouldn't be run.
+ $self->pointed_hint('run-parts-cron-filename-contains-illegal-chars',
+ $item->pointer)
+ if $item->name
+ =~ m{^ etc/cron[.] (?: daily | hourly | monthly | weekly |d ) / [^.] .* [+.] }x;
+
+ # /etc/cron.d
+ # NB: cron ships ".placeholder" files in etc/cron.d,
+ # which we shouldn't tag.
+ $self->pointed_hint('bad-permissions-for-etc-cron.d-script',
+ $item->pointer,
+ sprintf('%04o != %04o', $item->operm, $READ_WRITE_PERMISSIONS))
+ if $item->name =~ m{ ^ etc/cron\.d/ [^.] }msx
+ && $item->operm != $READ_WRITE_PERMISSIONS;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Cruft.pm b/lib/Lintian/Check/Cruft.pm
new file mode 100644
index 0000000..1a402c6
--- /dev/null
+++ b/lib/Lintian/Check/Cruft.pm
@@ -0,0 +1,836 @@
+# cruft -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Cruft;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none);
+
+const my $EMPTY => q{};
+const my $ASTERISK => q{*};
+const my $DOT => q{.};
+
+const my $ITEM_NOT_FOUND => -1;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Half of the size used in the "sliding window" for detecting bad
+# licenses like GFDL with invariant sections.
+# NB: Keep in sync cruft-gfdl-fp-sliding-win/pre_build.
+# not less than 8192 for source missing
+use constant BLOCKSIZE => 16_384;
+use Lintian::SlidingWindow;
+
+my %NVIDIA_LICENSE = (
+ keywords => [qw{license intellectual retain property}],
+ sentences =>[
+'retain all intellectual property and proprietary rights in and to this software and related documentation'
+ ]
+);
+
+my %NON_FREE_LICENSES = (
+# first field is tag
+# second field is a list of keywords in lower case
+# third field are lower case sentences to match the license. Notes that space are normalized before and formatting removed
+# fourth field is a regex to use to match the license, use lower case and [ ] for space.
+# 5th field is a function to call if the field 2th to 5th match.
+# (see dispatch table %LICENSE_CHECK_DISPATCH_TABLE
+
+ # json license
+ 'license-problem-json-evil' => {
+ keywords => [qw{software evil good}],
+ sentences => ['software shall be used for good'],
+ regex =>
+qr{software [ ] shall [ ] be [ ] used [ ] for [ ] good [ ]? ,? [ ]? not [ ] evil}msx
+ },
+ # non free RFC old version
+ 'license-problem-non-free-RFC' => {
+ keywords => [qw{document purpose translate language}],
+ sentences => ['this document itself may not be modified in any way'],
+ regex =>
+qr{this [ ] document [ ] itself [ ] may [ ] not [ ] be [ ] modified [ ] in [ ] any [ ] way [ ]?,
+ [ ]? such [ ] as [ ] by [ ] removing [ ] the [ ] copyright [ ] notice [ ] or [ ] references
+ [ ] to [ ] .{0,256} [ ]? except [ ] as [ ] needed [ ] for [ ] the [ ] purpose [ ] of [ ] developing
+ [ ] .{0,128} [ ]? in [ ] which [ ] case [ ] the [ ] procedures [ ] for [ ] copyrights [ ] defined
+ [ ] in [ ] the [ ] .{0,128} [ ]? process [ ] must [ ] be [ ] followed[ ]?,[ ]?
+ or [ ] as [ ] required [ ] to [ ] translate [ ] it [ ] into [ ] languages [ ]}msx,
+ callsub => 'rfc_whitelist_filename'
+ },
+ 'license-problem-non-free-RFC-BCP78' => {
+ keywords => [qw{license document bcp restriction}],
+ sentences => ['bcp 78'],
+ regex =>
+qr{this [ ] document [ ] is [ ] subject [ ] to [ ] (?:the [ ] rights [ ]?, [ ] licenses [ ] and [ ]restrictions [ ] contained [ ] in [ ])? bcp [ ] 78}msx,
+ callsub => 'rfc_whitelist_filename'
+ },
+# check GFDL block - The ".{0,1024}"-part in the regex
+# will contain the "no invariants etc." part if
+# it is a good use of the license. We include it
+# here to ensure that we do not emit a false positive
+# if the "redeeming" part is in the next block
+# keyword document is here in order to benefit for other license keyword and a shortcut for documentation
+ 'license-problem-gfdl-invariants' => {
+ keywords => [qw{license document gnu copy documentation}],
+ sentences => ['gnu free documentation license'],
+ regex =>
+qr{(?'rawcontextbefore'(?:(?:(?!a [ ] copy [ ] of [ ] the [ ] license [ ] is).){1024}|
+\A(?:(?!a [ ] copy [ ] of [ ] the [ ] license [ ] is).){0,1024}|
+(?:[ ] copy [ ] of [ ] the [ ] license [ ] is.{0,1024}?))) gnu [ ] free [ ]
+documentation [ ] license (?'rawgfdlsections'(?:(?!gnu [ ] free [ ] documentation
+[ ] license).){0,1024}?) (?:a [ ] copy [ ] of [ ] the [ ] license [ ] is|
+this [ ] document [ ] is [ ] distributed)}msx,
+ callsub => 'check_gfdl_license_problem'
+ },
+ # php license
+ 'license-problem-php-license' => {
+ keywords => [qw{www.php.net group\@php.net phpfoo conjunction php}],
+ sentences => ['this product includes php'],
+ regex => qr{php [ ] license [ ]?[,;][ ]? version [ ] 3(?:\.\d+)?}msx,
+ callsub => 'php_source_whitelist'
+ },
+ 'license-problem-bad-php-license' => {
+ keywords => [qw{www.php.net add-on conjunction}],
+ sentences => ['this product includes php'],
+ regex => qr{php [ ] license [ ]?[,;][ ]? version [ ] 2(?:\.\d+)?}msx,
+ callsub => 'php_source_whitelist'
+ },
+ # cc by nc sa note that " is replaced by [ ]
+ 'license-problem-cc-by-nc-sa' => {
+ keywords => [qw{license by-nc-sa creativecommons.org}],
+ sentences => [
+ '://creativecommons.org/licenses/by-nc-sa',
+ 'under attribution-noncommercial'
+ ],
+ regex =>
+qr{(?:license [ ] rdf:[^=:]+=[ ]* (?:ht|f)tps?://(?:[^/.]\.)??creativecommons\.org/licenses/by-nc-sa/\d+(?:\.\d+)?(?:/[[:alpha:]]+)?/? [ ]* >|available [ ] under [ ] attribution-noncommercial)}msx
+ },
+ # not really a license but warn it: visual c++ generated file
+ 'source-contains-autogenerated-visual-c++-file' => {
+ keywords => [qw{microsoft visual generated}],
+ sentences => ['microsoft visual c++ generated'],
+ regex =>
+qr{microsoft [ ] visual [ ] c[+][+] [ ] generated (?![ ] by [ ] freeze\.py)}msx
+ },
+ # not really a license but warn about it: gperf generated file
+ 'source-contains-autogenerated-gperf-data' => {
+ keywords => [qw{code produced gperf version}],
+ sentences => ['code produced by gperf version'],
+ regex =>
+ qr{code [ ] produced [ ] by [ ] gperf [ ] version [ ] \d+\.\d+}msx
+ },
+ # warn about copy of ieee-data
+ 'source-contains-data-from-ieee-data-oui-db' => {
+ keywords => [qw{struck scitex racore}],
+ sentences => ['dr. b. struck'],
+ regex => qr{dr. [ ] b. [ ] struck}msx
+ },
+ # warn about unicode license for utf for convert utf
+ 'license-problem-convert-utf-code' => {
+ keywords => [qw{fall-through bytestowrite utf-8}],
+ sentences => ['the fall-through switches in utf-8 reading'],
+ regex =>
+qr{the [ ] fall-through [ ] switches [ ] in [ ] utf-8 [ ] reading [ ] code [ ] save}msx
+ }
+);
+
+# get usual data about admissible/not admissible GFDL invariant part of license
+has GFDL_FRAGMENTS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %gfdl_fragments;
+
+ my $data = $self->data->load('cruft/gfdl-license-fragments-checks',
+ qr/\s*\~\~\s*/);
+
+ for my $gfdlsectionsregex ($data->all) {
+
+ my $secondpart = $data->value($gfdlsectionsregex);
+
+ # allow empty parameters
+ $secondpart //= $EMPTY;
+ my ($acceptonlyinfile,$applytag)
+ = split(/\s*\~\~\s*/, $secondpart, 2);
+
+ $acceptonlyinfile //= $EMPTY;
+ $applytag //= $EMPTY;
+
+ # trim both ends
+ $acceptonlyinfile =~ s/^\s+|\s+$//g;
+ $applytag =~ s/^\s+|\s+$//g;
+
+ # accept all files if empty
+ $acceptonlyinfile ||= $DOT . $ASTERISK;
+
+ my %ret = (
+ 'gfdlsectionsregex' => qr/$gfdlsectionsregex/xis,
+ 'acceptonlyinfile' => qr/$acceptonlyinfile/xs,
+ );
+
+ $ret{'tag'} = $applytag
+ if length $applytag;
+
+ $gfdl_fragments{$gfdlsectionsregex} = \%ret;
+ }
+
+ return \%gfdl_fragments;
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # license string in debian/changelog are probably just change
+ # Ignore these strings in d/README.{Debian,source}. If they
+ # appear there it is probably just "file XXX got removed
+ # because of license Y".
+ $self->full_text_check($item)
+ unless $item->name eq 'debian/changelog'
+ && $item->name eq 'debian/README.Debian'
+ && $item->name eq 'debian/README.source';
+
+ return;
+}
+
+# do basic license check against well known offender
+# note that it does not replace licensecheck(1)
+# and is only used for autoreject by ftp-master
+sub full_text_check {
+ my ($self, $item) = @_;
+
+ return undef
+ unless $item ->is_regular_file;
+
+ open(my $fd, '<:raw', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $sfd = Lintian::SlidingWindow->new;
+ $sfd->handle($fd);
+ $sfd->blocksize(BLOCKSIZE);
+ $sfd->blocksub(sub { $_ = lc; });
+
+ unless (-T $fd) {
+ close($fd);
+ return undef;
+ }
+
+ # we try to read this file in block and use a sliding window
+ # for efficiency. We store two blocks in @queue and the whole
+ # string to match in $block. Please emit license tags only once
+ # per file
+ BLOCK:
+ while (my $lowercase = $sfd->readwindow()) {
+
+ my $blocknumber = $sfd->blocknumber();
+
+ my $clean = clean_text($lowercase);
+
+ # Check for non-distributable files - this
+ # applies even to non-free, as we still need
+ # permission to distribute those.
+ # nvdia opencv infamous license
+ last BLOCK
+ if $self->check_for_single_bad_license($item, $lowercase, $clean,
+ 'license-problem-nvidia-intellectual',
+ \%NVIDIA_LICENSE);
+
+ unless ($self->processable->is_non_free) {
+
+ for my $tag_name (keys %NON_FREE_LICENSES) {
+
+ last BLOCK
+ if $self->check_for_single_bad_license($item, $lowercase,
+ $clean,$tag_name, $NON_FREE_LICENSES{$tag_name});
+ }
+ }
+
+ # check javascript in html file
+ if ($item->basename =~ /\.(?:x?html?\d?|xht)$/i) {
+
+ my $blockscript = $lowercase;
+ my $indexscript;
+
+ while (($indexscript = index($blockscript, '<script'))
+ > $ITEM_NOT_FOUND){
+
+ $blockscript = substr($blockscript,$indexscript);
+
+ # sourced script ok
+ if ($blockscript =~ m{\A<script\s+[^>]*?src="[^"]+?"[^>]*?>}sm)
+ {
+
+ $blockscript = substr($blockscript,$+[0]);
+ next;
+ }
+
+ # extract script
+ if ($blockscript =~ m{<script[^>]*?>(.*?)</script>}sm) {
+
+ $blockscript = substr($blockscript,$+[0]);
+
+ my $lcscript = $1;
+
+ # check if js script is minified
+ my $firstline = $EMPTY;
+ for my $line (split /\n/, $lcscript) {
+
+ if ($line =~ /^\s*$/) {
+ next;
+
+ } else {
+ $firstline = $line;
+ last;
+ }
+ }
+
+ if ($firstline
+ =~ m/.{0,20}((?:\bcopyright\b|[\(]c[\)]\s*\w|\N{COPYRIGHT SIGN}).{0,50})/
+ ){
+
+ my $extract = $1;
+ $extract =~ s/^\s+|\s+$//g;
+
+ $self->pointed_hint(
+ 'embedded-script-includes-copyright-statement',
+ $item->pointer,
+ 'extract of copyright statement:',
+ $extract
+ );
+ }
+
+ # clean up jslint craps line
+ my $cleaned = $lcscript;
+ $cleaned =~ s{^\s*/[*][^\n]*[*]/\s*$}{}gm;
+ $cleaned =~ s{^\s*//[^\n]*$}{}gm;
+ $cleaned =~ s/^\s+//gm;
+
+ # strip indentation
+ $cleaned =~ s/^\s+//mg;
+ $cleaned = _strip_c_comments($cleaned);
+ # strip empty line
+ $cleaned =~ s/^\s*\n//mg;
+ # remove last \n
+ $cleaned =~ s/\n\Z//m;
+
+# detect browserified javascript (comment are removed here and code is stripped)
+ my $contiguous = $cleaned;
+ $contiguous =~ s/\n/ /msg;
+
+ # get browserified regexp
+ my $BROWSERIFY_REGEX
+ = $self->data->load('cruft/browserify-regex',
+ qr/\s*\~\~\s*/);
+
+ for my $condition ($BROWSERIFY_REGEX->all) {
+
+ my $pattern = $BROWSERIFY_REGEX->value($condition);
+ if ($contiguous =~ m{$pattern}msx) {
+
+ my $extra
+ = (defined $1) ? 'code fragment:'.$1 : $EMPTY;
+ $self->pointed_hint(
+ 'source-contains-browserified-javascript',
+ $item->pointer, $extra);
+
+ last;
+ }
+ }
+
+ next;
+ }
+
+ last;
+ }
+ }
+
+ # check if file is javascript but not minified
+ my $isjsfile = ($item->name =~ m/\.js$/) ? 1 : 0;
+ if ($isjsfile) {
+ my $minjsregexp
+ = qr/(?i)[-._](?:compiled|compressed|lite|min|pack(?:ed)?|prod|umd|yc)\.js$/;
+ $isjsfile = ($item->name =~ m{$minjsregexp}) ? 0 : 1;
+ }
+
+ if ($isjsfile) {
+ # exception sphinx documentation
+ if ($item->basename eq 'searchindex.js') {
+ if ($lowercase =~ m/\A\s*search\.setindex\s* \s* \(\s*\{/xms) {
+
+ $self->pointed_hint(
+ 'source-contains-prebuilt-sphinx-documentation',
+ $item->parent_dir->pointer);
+ last BLOCK;
+ }
+ }
+
+ if ($item->basename eq 'search_index.js') {
+ if ($lowercase =~ m/\A\s*var\s*search_index\s*=/xms) {
+
+ $self->pointed_hint(
+ 'source-contains-prebuilt-pandoc-documentation',
+ $item->parent_dir->pointer);
+ last BLOCK;
+ }
+ }
+ # false positive in dx package at least
+ elsif ($item->basename eq 'srchidx.js') {
+
+ last BLOCK
+ if $lowercase
+ =~ m/\A\s*profiles \s* = \s* new \s* Array\s*\(/xms;
+ }
+ # https://github.com/rafaelp/css_browser_selector is actually the
+ # original source. (#874381)
+ elsif ($lowercase =~ m/css_browser_selector\(/) {
+
+ last BLOCK;
+ }
+ # Avoid false-positives in Jush's syntax highlighting definition files.
+ elsif ($lowercase =~ m/jush\.tr\./) {
+
+ last BLOCK;
+ }
+
+ # now search hidden minified
+
+ # clean up jslint craps line
+ my $cleaned = $lowercase;
+ $cleaned =~ s{^\s*/[*][^\n]*[*]/\s*$}{}gm;
+ $cleaned =~ s{^\s*//[^\n]*$}{}gm;
+ $cleaned =~ s/^\s+//gm;
+
+ # strip indentation
+ $cleaned =~ s/^\s+//mg;
+ $cleaned = _strip_c_comments($cleaned);
+ # strip empty line
+ $cleaned =~ s/^\s*\n//mg;
+ # remove last \n
+ $cleaned =~ s/\n\Z//m;
+
+# detect browserified javascript (comment are removed here and code is stripped)
+ my $contiguous = $cleaned;
+ $contiguous =~ s/\n/ /msg;
+
+ # get browserified regexp
+ my $BROWSERIFY_REGEX
+ = $self->data->load('cruft/browserify-regex',qr/\s*\~\~\s*/);
+
+ for my $condition ($BROWSERIFY_REGEX->all) {
+
+ my $pattern = $BROWSERIFY_REGEX->value($condition);
+ if ($contiguous =~ m{$pattern}msx) {
+
+ my $extra = (defined $1) ? 'code fragment:'.$1 : $EMPTY;
+ $self->pointed_hint(
+ 'source-contains-browserified-javascript',
+ $item->pointer, $extra);
+
+ last;
+ }
+ }
+ }
+
+ # search link rel header
+ if ($lowercase =~ / \Q rel="copyright" \E /msx) {
+
+ my $href = $lowercase;
+ $href =~ m{<link \s+
+ rel="copyright" \s+
+ href="([^"]+)" \s*/? \s*>}xmsi;
+
+ my $url = $1 // $EMPTY;
+
+ $self->pointed_hint('license-problem-cc-by-nc-sa', $item->pointer)
+ if $url =~ m{^https?://creativecommons.org/licenses/by-nc-sa/};
+ }
+ last BLOCK;
+ }
+ return close($fd);
+}
+
+# strip C comment
+# warning block is at more 8192 char in order to be too slow
+# and in order to avoid regex recursion
+sub _strip_c_comments {
+ my ($lowercase) = @_;
+
+ # from perl faq strip comments
+ $lowercase =~ s{
+ # Strip /* */ comments
+ /\* [^*]*+ \*++ (?: [^/*][^*]*+\*++ ) */
+ # Strip // comments (C++ style)
+ | // (?: [^\\] | [^\n][\n]? )*? (?=\n)
+ | (
+ # Keep "/* */" (etc) as is
+ "(?: \\. | [^"\\]++)*"
+ # Keep '/**/' (etc) as is
+ | '(?: \\. | [^'\\]++)*'
+ # Keep anything else
+ | .[^/"'\\]*+
+ )
+ }{defined $1 ? $1 : ""}xgse;
+
+ return $lowercase;
+}
+
+# return True in case of license problem
+sub check_gfdl_license_problem {
+ my ($self, $item, $tag_name, %matchedhash) = @_;
+
+ my $rawgfdlsections = $matchedhash{rawgfdlsections} || $EMPTY;
+ my $rawcontextbefore = $matchedhash{rawcontextbefore} || $EMPTY;
+
+ # strip punctuation
+ my $gfdlsections = _strip_punct($rawgfdlsections);
+ my $contextbefore = _strip_punct($rawcontextbefore);
+
+ # remove line number at beginning of line
+ # see krusader/1:2.4.0~beta3-2/doc/en_US/advanced-functions.docbook/
+ $gfdlsections =~ s{[ ]\d+[ ]}{ }gxsmo;
+ $gfdlsections =~ s{^\d+[ ]}{ }xsmo;
+ $gfdlsections =~ s{[ ]\d+$}{ }xsmo;
+ $gfdlsections =~ s{[ ]+}{ }xsmo;
+
+ # remove classical and without meaning part of
+ # matched string
+ my $oldgfdlsections;
+ do {
+ $oldgfdlsections = $gfdlsections;
+ $gfdlsections =~ s{ \A \(?[ ]? g?fdl [ ]?\)?[ ]? [,\.;]?[ ]?}{}xsmo;
+ $gfdlsections =~ s{ \A (?:either[ ])?
+ version [ ] \d+(?:\.\d+)? [ ]?}{}xsmo;
+ $gfdlsections =~ s{ \A of [ ] the [ ] license [ ]?[,\.;][ ]?}{}xsmo;
+ $gfdlsections=~ s{ \A or (?:[ ]\(?[ ]? at [ ] your [ ] option [ ]?\)?)?
+ [ ] any [ ] later [ ] version[ ]?}{}xsmo;
+ $gfdlsections =~ s{ \A (as[ ])? published [ ] by [ ]
+ the [ ] free [ ] software [ ] foundation[ ]?}{}xsmo;
+ $gfdlsections =~ s{\(?[ ]? fsf [ ]?\)?[ ]?}{}xsmo;
+ $gfdlsections =~ s{\A [ ]? [,\.;]? [ ]?}{}xsmo;
+ $gfdlsections =~ s{[ ]? [,\.]? [ ]?\Z}{}xsmo;
+ } while ($oldgfdlsections ne $gfdlsections);
+
+ $contextbefore =~ s{
+ [ ]? (:?[,\.;]? [ ]?)?
+ permission [ ] is [ ] granted [ ] to [ ] copy [ ]?[,\.;]?[ ]?
+ distribute [ ]?[,\.;]?[ ]? and[ ]?/?[ ]?or [ ] modify [ ]
+ this [ ] document [ ] under [ ] the [ ] terms [ ] of [ ] the\Z}{}xsmo;
+
+ # Treat ambiguous empty text
+ if ($gfdlsections eq $EMPTY) {
+
+ # lie in order to check more part
+ $self->pointed_hint('license-problem-gfdl-invariants-empty',
+ $item->pointer);
+
+ return 0;
+ }
+
+ # official wording
+ if(
+ $gfdlsections =~ m{\A
+ with [ ] no [ ] invariant [ ] sections[ ]?,
+ [ ]? no [ ] front(?:[ ]?-[ ]?|[ ])cover [ ] texts[ ]?,?
+ [ ]? and [ ] no [ ] back(?:[ ]?-?[ ]?|[ ])cover [ ] texts
+ \Z}xs
+ ) {
+ return 0;
+ }
+
+ # example are ok
+ if (
+ $contextbefore =~ m{following [ ] is [ ] an [ ] example
+ (:?[ ] of [ ] the [ ] license [ ] notice [ ] to [ ] use
+ (?:[ ] after [ ] the [ ] copyright [ ] (?:line(?:\(s\)|s)?)?
+ (?:[ ] using [ ] all [ ] the [ ] features? [ ] of [ ] the [ ] gfdl)?
+ )?
+ )? [ ]? [,:]? \Z}xs
+ ){
+ return 0;
+ }
+
+ # GFDL license, assume it is bad unless it
+ # explicitly states it has no "bad sections".
+ for my $gfdl_fragment (keys %{$self->GFDL_FRAGMENTS}) {
+
+ my $gfdl_data = $self->GFDL_FRAGMENTS->{$gfdl_fragment};
+ my $gfdlsectionsregex = $gfdl_data->{'gfdlsectionsregex'};
+ if ($gfdlsections =~ m{$gfdlsectionsregex}) {
+
+ my $acceptonlyinfile = $gfdl_data->{'acceptonlyinfile'};
+ if ($item->name =~ m{$acceptonlyinfile}) {
+
+ my $applytag = $gfdl_data->{'tag'};
+
+ # lie will allow checking more blocks
+ $self->pointed_hint($applytag, $item->pointer,
+ 'invariant part is:',
+ $gfdlsections)
+ if defined $applytag;
+
+ return 0;
+
+ } else {
+ $self->pointed_hint(
+ 'license-problem-gfdl-invariants',
+ $item->pointer,'invariant part is:',
+ $gfdlsections
+ );
+ return 1;
+ }
+ }
+ }
+
+ # catch all
+ $self->pointed_hint(
+ 'license-problem-gfdl-invariants',
+ $item->pointer,'invariant part is:',
+ $gfdlsections
+ );
+
+ return 1;
+}
+
+sub rfc_whitelist_filename {
+ my ($self, $item, $tag_name, %matchedhash) = @_;
+
+ return 0
+ if $item->name eq 'debian/copyright';
+
+ my $lcname = lc($item->basename);
+
+ # prebuilt-file or forbidden file type
+ # specified separator protects against spaces in pattern
+ my $RFC_WHITELIST= $self->data->load('cruft/rfc-whitelist',qr/\s*\~\~\s*/);
+
+ my @patterns = $RFC_WHITELIST->all;
+
+ return 0
+ if any { $lcname =~ m/ $_ /xms } @patterns;
+
+ $self->pointed_hint($tag_name, $item->pointer);
+
+ return 1;
+}
+
+sub php_source_whitelist {
+ my ($self, $item, $tag_name, %matchedhash) = @_;
+
+ my $copyright_path
+ = $self->processable->patched->resolve_path('debian/copyright');
+
+ return 0
+ if defined $copyright_path
+ && $copyright_path->bytes
+ =~ m{^Source: https?://(pecl|pear).php.net/package/.*$}m;
+
+ return 0
+ if $self->processable->source_name =~ /^php\d*(?:\.\d+)?$/xms;
+
+ $self->pointed_hint($tag_name, $item->pointer);
+
+ return 1;
+}
+
+sub clean_text {
+ my ($text) = @_;
+
+ # be paranoiac replace gnu with texinfo by gnu
+ $text =~ s{
+ (?:@[[:alpha:]]*?\{)?\s*gnu\s*\} # Texinfo cmd
+ }{ gnu }gxms;
+
+ # pod2man formatting
+ $text =~ s{ \\ \* \( [LR] \" }{\"}gxsm;
+ $text =~ s{ \\ -}{-}gxsm;
+
+ # replace some shortcut (clisp)
+ $text =~ s{\(&fdl;\)}{ }gxsm;
+ $text =~ s{&fsf;}{free software foundation}gxsm;
+
+ # non breaking space
+ $text =~ s{&nbsp;}{ }gxsm;
+
+ # replace some common comment-marker/markup with space
+ $text =~ s{^\.\\\"}{ }gxms; # man comments
+
+ # po comment may include html tag
+ $text =~ s/\"\s?\v\#~\s?\"//gxms;
+
+ # strip .rtf paragraph marks (#892967)
+ $text =~ s/\\par\b//gxms;
+
+ $text =~ s/\\url[{][^}]*?[}]/ /gxms; # (la)?tex url
+ $text =~ s/\\emph[{]/ /gxms; # (la)?tex emph
+ $text =~ s<\\href[{][^}]*?[}]
+ [{]([^}]*?)[}]>< $1 >gxms;# (la)?tex href
+ $text =~ s<\\hyperlink
+ [{][^}]*?[}]
+ [{]([^}]*?)[}]>< $1 >gxms; # (la)?tex hyperlink
+ $text =~ s{-\\/}{-}gxms; # tex strange hyphen
+ $text =~ s/\\char/ /gxms; # tex char command
+
+ # Texinfo comment with end section
+ $text =~ s{\@c(?:omment)?\h+
+ end \h+ ifman\s+}{ }gxms;
+ $text =~ s{\@c(?:omment)?\s+
+ noman\s+}{ }gxms; # Texinfo comment no manual
+
+ $text =~ s/\@c(?:omment)?\s+/ /gxms; # Texinfo comment
+
+ # Texinfo bold,italic, roman, fixed width
+ $text =~ s/\@[birt][{]/ /gxms;
+ $text =~ s/\@sansserif[{]/ /gxms; # Texinfo sans serif
+ $text =~ s/\@slanted[{]/ /gxms; # Texinfo slanted
+ $text =~ s/\@var[{]/ /gxms; # Texinfo emphasis
+
+ $text =~ s/\@(?:small)?example\s+/ /gxms; # Texinfo example
+ $text =~ s{\@end \h+
+ (?:small)example\s+}{ }gxms; # Texinfo end example tag
+ $text =~ s/\@group\s+/ /gxms; # Texinfo group
+ $text =~ s/\@end\h+group\s+/ /gxms; # Texinfo end group
+
+ $text =~ s/<!--/ /gxms; # XML comments
+ $text =~ s/-->/ /gxms; # end XML comment
+
+ $text =~ s{</?a[^>]*?>}{ }gxms; # a link
+ $text =~ s{<br\s*/?>}{ }gxms; # (X)?HTML line
+ # breaks
+ $text =~ s{</?citetitle[^>]*?>}{ }gxms; # DocBook citation title
+ $text =~ s{</?div[^>]*?>}{ }gxms; # html style
+ $text =~ s{</?font[^>]*?>}{ }gxms; # bold
+ $text =~ s{</?b[^>]*?>}{ }gxms; # italic
+ $text =~ s{</?i[^>]*?>}{ }gxms; # italic
+ $text =~ s{</?link[^>]*?>}{ }gxms; # xml link
+ $text =~ s{</?p[^>]*?>}{ }gxms; # html paragraph
+ $text =~ s{</?quote[^>]*?>}{ }gxms; # xml quote
+ $text =~ s{</?span[^>]*?>}{ }gxms; # span tag
+ $text =~ s{</?ulink[^>]*?>}{ }gxms; # ulink DocBook
+ $text =~ s{</?var[^>]*?>}{ }gxms; # var used by texinfo2html
+
+ $text =~ s{\&[lr]dquo;}{ }gxms; # html rquote
+
+ $text =~ s{\(\*note.*?::\)}{ }gxms; # info file note
+
+ # String array (e.g. "line1",\n"line2")
+ $text =~ s/\"\s*,/ /gxms;
+ # String array (e.g. "line1"\n ,"line2"),
+ $text =~ s/,\s*\"/ /gxms;
+ $text =~ s/\\n/ /gxms; # Verbatim \n in string array
+
+ $text =~ s/\\&/ /gxms; # pod2man formatting
+ $text =~ s/\\s(?:0|-1)/ /gxms; # pod2man formatting
+
+ $text =~ s/(?:``|'')/ /gxms; # quote like
+
+ # diff/patch lines (should be after html tag)
+ $text =~ s/^[-\+!<>]/ /gxms;
+ $text =~ s{\@\@ \s*
+ [-+] \d+,\d+ \s+
+ [-+] \d+,\d+ \s*
+ \@\@}{ }gxms; # patch line
+
+ # Texinfo end tag (could be more clever but brute force is fast)
+ $text =~ s/}/ /gxms;
+ # Tex section titles
+ $text =~ s/^\s*\\(sub)*section\*?\{\s*\S+/ /gxms;
+ # single char at end
+ # String, C-style comment/javadoc indent,
+ # quotes for strings, pipe and backslash, tilde in some txt
+ $text =~ s/[%\*\"\|\\\#~]/ /gxms;
+ # delete double spacing now and normalize spacing
+ # to space character
+ $text =~ s{\s++}{ }gsm;
+
+ # trim both ends
+ $text =~ s/^\s+|\s+$//g;
+
+ return $text;
+}
+
+# do not use space around punctuation
+sub _strip_punct() {
+ my ($text) = @_;
+ # replace final punctuation
+ $text =~ s{(?:
+ \s*[,\.;]\s*\Z | # final punctuation
+ \A\s*[,\.;]\s* # punctuation at the beginning
+ )}{ }gxms;
+
+ # delete double spacing now and normalize spacing
+ # to space character
+ $text =~ s{\s++}{ }gsm;
+
+ # trim both ends
+ $text =~ s/^\s+|\s+$//g;
+
+ return $text;
+}
+
+sub check_for_single_bad_license {
+ my ($self, $item, $lowercase, $clean, $tag_name, $license_data) = @_;
+
+ # do fast keyword search
+ # could make more sense as 'return 1 unless all' but does not work
+ return 0
+ if none { $lowercase =~ / \Q$_\E /msx } @{$license_data->{keywords}};
+
+ return 0
+ if none { $clean =~ / \Q$_\E /msx }@{$license_data->{sentences}};
+
+ my $regex = $license_data->{regex};
+ return 0
+ if defined $regex && $clean !~ $regex;
+
+ my $callsub = $license_data->{callsub};
+ if (!defined $callsub) {
+
+ $self->pointed_hint($tag_name, $item->pointer);
+ return 1;
+ }
+
+ return $self->$callsub($item, $tag_name, %+);
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/DebFormat.pm b/lib/Lintian/Check/DebFormat.pm
new file mode 100644
index 0000000..57c57a4
--- /dev/null
+++ b/lib/Lintian/Check/DebFormat.pm
@@ -0,0 +1,227 @@
+# deb-format -- lintian check script -*- perl -*-
+
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Check::DebFormat;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use IPC::Run3;
+use List::SomeUtils qw(first_index none);
+use Path::Tiny;
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+const my $MINIMUM_DEB_ARCHIVE_MEMBERS => 3;
+const my $INDEX_NOT_FOUND => -1;
+
+sub installable {
+ my ($self) = @_;
+
+ my $EXTRA_MEMBERS = $self->data->load('deb-format/extra-members');
+
+ my $deb_path = $self->processable->path;
+
+ # set to one when something is so bad that we can't continue
+ my $failed;
+
+ my @command = ('ar', 't', $deb_path);
+
+ my $stdout;
+ my $stderr;
+
+ run3(\@command, \undef, \$stdout, \$stderr);
+
+ unless ($?) {
+ my @members = split(/\n/, $stdout);
+ my $count = scalar(@members);
+ my ($ctrl_member, $data_member);
+
+ if ($count < $MINIMUM_DEB_ARCHIVE_MEMBERS) {
+ $self->hint('malformed-deb-archive',
+"found only $count members instead of $MINIMUM_DEB_ARCHIVE_MEMBERS"
+ );
+
+ } elsif ($members[0] ne 'debian-binary') {
+ $self->hint('malformed-deb-archive',
+ "first member $members[0] not debian-binary");
+
+ } elsif ($count == $MINIMUM_DEB_ARCHIVE_MEMBERS
+ && none {substr($_, 0, 1) eq '_';}@members) {
+ # Fairly common case - if there are only 3 members without
+ # "_", we can trivially determine their (expected)
+ # positions. We only use this case when there are no
+ # "extra" members, because they can trigger more tags
+ # (see below)
+ (undef, $ctrl_member, $data_member) = @members;
+
+ } else {
+ my $ctrl_index
+ = first_index { substr($_, 0, 1) ne '_' } @members[1..$#members];
+ my $data_index;
+
+ if ($ctrl_index != $INDEX_NOT_FOUND) {
+ # Since we searched only a sublist of @members, we have to
+ # add 1 to $ctrl_index
+ $ctrl_index++;
+ $ctrl_member = $members[$ctrl_index];
+ $data_index = first_index { substr($_, 0, 1) ne '_' }
+ @members[$ctrl_index+1..$#members];
+ if ($data_index != $INDEX_NOT_FOUND) {
+ # Since we searched only a sublist of @members, we
+ # have to adjust $data_index
+ $data_index += $ctrl_index + 1;
+ $data_member = $members[$data_index];
+ }
+ }
+
+ # Extra members
+ # NB: We deliberately do not allow _extra member,
+ # since various tools seems to be unable to cope
+ # with them particularly dak
+ # see https://wiki.debian.org/Teams/Dpkg/DebSupport
+ for my $i (1..$#members) {
+ my $member = $members[$i];
+ my $actual_index = $i;
+ my ($expected, $text);
+ next if $i == $ctrl_index or $i == $data_index;
+ $expected = $EXTRA_MEMBERS->value($member);
+ if (defined($expected)) {
+ next if $expected eq 'ANYWHERE';
+ next if $expected == $actual_index;
+ $text = "expected at position $expected, but appeared";
+ } elsif (substr($member,0,1) eq '_') {
+ $text = 'unexpected _member';
+ } else {
+ $text = 'unexpected member';
+ }
+ $self->hint('misplaced-extra-member-in-deb',
+ "$member ($text at position $actual_index)");
+ }
+ }
+
+ if (not defined($ctrl_member)) {
+ # Somehow I doubt we will ever get this far without a control
+ # file... :)
+ $self->hint('malformed-deb-archive', 'Missing control.tar member');
+ $failed = 1;
+ } else {
+ if (
+ $ctrl_member !~ m{\A
+ control\.tar(?:\.(?:gz|xz))? \Z}xsm
+ ) {
+ $self->hint(
+ 'malformed-deb-archive',
+ join($SPACE,
+ "second (official) member $ctrl_member",
+ 'not control.tar.(gz|xz)')
+ );
+ $failed = 1;
+ } elsif ($ctrl_member eq 'control.tar') {
+ $self->hint('uses-no-compression-for-control-tarball');
+ }
+ $self->hint('control-tarball-compression-format',
+ $ctrl_member =~ s/^control\.tar\.?//r || '(none)');
+ }
+
+ if (not defined($data_member)) {
+ # Somehow I doubt we will ever get this far without a data
+ # member (i.e. I suspect unpacked and index will fail), but
+ # mah
+ $self->hint('malformed-deb-archive', 'Missing data.tar member');
+ $failed = 1;
+ } else {
+ if (
+ $data_member !~ m{\A
+ data\.tar(?:\.(?:gz|bz2|xz|lzma))? \Z}xsm
+ ) {
+ # wasn't okay after all
+ $self->hint(
+ 'malformed-deb-archive',
+ join($SPACE,
+ "third (official) member $data_member",
+ 'not data.tar.(gz|xz|bz2|lzma)')
+ );
+ $failed = 1;
+ } elsif ($self->processable->type eq 'udeb'
+ && $data_member !~ m/^data\.tar\.[gx]z$/) {
+ $self->hint(
+ 'udeb-uses-unsupported-compression-for-data-tarball');
+ } elsif ($data_member eq 'data.tar.lzma') {
+ $self->hint('uses-deprecated-compression-for-data-tarball',
+ 'lzma');
+ # Ubuntu's archive allows lzma packages.
+ $self->hint('lzma-deb-archive');
+ } elsif ($data_member eq 'data.tar.bz2') {
+ $self->hint('uses-deprecated-compression-for-data-tarball',
+ 'bzip2');
+ } elsif ($data_member eq 'data.tar') {
+ $self->hint('uses-no-compression-for-data-tarball');
+ }
+ $self->hint('data-tarball-compression-format',
+ $data_member =~ s/^data\.tar\.?//r || '(none)');
+ }
+ } else {
+ # unpack will probably fail so we'll never get here, but may as well be
+ # complete just in case.
+ $stderr =~ s/\n.*//s;
+ $stderr =~ s/^ar:\s*//;
+ $stderr =~ s/^deb:\s*//;
+ $self->hint('malformed-deb-archive', "ar error: $stderr");
+ }
+
+ # Check the debian-binary version number. We probably won't get
+ # here because dpkg-deb will decline to unpack the deb, but be
+ # thorough just in case. We may eventually have a case where dpkg
+ # supports a newer format but it's not permitted in the archive
+ # yet.
+ if (not defined($failed)) {
+ my $bytes = safe_qx('ar', 'p', $deb_path, 'debian-binary');
+ if ($? != 0) {
+ $self->hint('malformed-deb-archive',
+ 'cannot read debian-binary member');
+ } else {
+ my $output = decode_utf8($bytes);
+ if ($output !~ /^2\.\d+\n/) {
+ my ($version) = split(m/\n/, $output);
+ $self->hint('malformed-deb-archive',
+ "version $version not 2.0");
+ }
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debhelper.pm b/lib/Lintian/Check/Debhelper.pm
new file mode 100644
index 0000000..b2cee04
--- /dev/null
+++ b/lib/Lintian/Check/Debhelper.pm
@@ -0,0 +1,1088 @@
+# debhelper format -- lintian check script -*- perl -*-
+
+# Copyright (C) 1999 by Joey Hess
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debhelper;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any firstval);
+use List::UtilsBy qw(min_by);
+use Text::LevenshteinXS qw(distance);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $DOLLAR => q{$};
+const my $UNDERSCORE => q{_};
+const my $HORIZONTAL_BAR => q{|};
+
+const my $ARROW => q{=>};
+
+# If there is no debian/compat file present but cdbs is being used, cdbs will
+# create one automatically. Currently it always uses compatibility level 5.
+# It may be better to look at what version of cdbs the package depends on and
+# from that derive the compatibility level....
+const my $CDBS_COMPAT => 5;
+
+# minimum versions for features
+const my $BRACE_EXPANSION => 5;
+const my $USES_EXECUTABLE_FILES => 9;
+const my $DH_PARALLEL_NOT_NEEDED => 10;
+const my $REQUIRES_AUTOTOOLS => 10;
+const my $USES_AUTORECONF => 10;
+const my $INVOKES_SYSTEMD => 10;
+const my $BETTER_SYSTEMD_INTEGRATION => 11;
+const my $VERSIONED_PREREQUISITE_AVAILABLE => 11;
+
+const my $LEVENSHTEIN_TOLERANCE => 3;
+const my $MANY_OVERRIDES => 20;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my $MISC_DEPENDS = Lintian::Relation->new->load($DOLLAR . '{misc:Depends}');
+
+# Manually maintained list of dh_commands that requires a versioned
+# dependency *AND* are not provided by debhelper. Commands provided
+# by debhelper is handled in checks/debhelper.
+#
+# This overrules any thing listed in dh_commands (which is auto-generated).
+
+my %DH_COMMAND_MANUAL_PREREQUISITES = (
+ dh_apache2 => 'dh-apache2:any | apache2-dev:any',
+ dh_autoreconf_clean =>
+'dh-autoreconf:any | debhelper:any (>= 9.20160403~) | debhelper-compat:any',
+ dh_autoreconf =>
+'dh-autoreconf:any | debhelper:any (>= 9.20160403~) | debhelper-compat:any',
+ dh_dkms => 'dh-dkms:any | dh-sequence-dkms:any',
+ dh_girepository => 'gobject-introspection:any | dh-sequence-gir:any',
+ dh_gnome => 'gnome-pkg-tools:any | dh-sequence-gnome:any',
+ dh_gnome_clean => 'gnome-pkg-tools:any | dh-sequence-gnome:any',
+ dh_lv2config => 'lv2core:any',
+ dh_make_pgxs => 'postgresql-server-dev-all:any | postgresql-all:any',
+ dh_nativejava => 'gcj-native-helper:any | default-jdk-builddep:any',
+ dh_pgxs_test => 'postgresql-server-dev-all:any | postgresql-all:any',
+ dh_python2 => 'dh-python:any | dh-sequence-python2:any',
+ dh_python3 =>
+ 'dh-python:any | dh-sequence-python3:any | pybuild-plugin-pyproject:any',
+ dh_sphinxdoc =>
+'sphinx:any | python-sphinx:any | python3-sphinx:any | dh-sequence-sphinxdoc:any',
+ dh_xine => 'libxine-dev:any | libxine2-dev:any'
+);
+
+# Manually maintained list of dependencies needed for dh addons. This overrides
+# information from data/common/dh_addons (the latter file is automatically
+# generated).
+my %DH_ADDON_MANUAL_PREREQUISITES = (
+ ada_library => 'dh-ada-library:any | dh-sequence-ada-library:any',
+ apache2 => 'dh-apache2:any | apache2-dev:any',
+ autoreconf =>
+'dh-autoreconf:any | debhelper:any (>= 9.20160403~) | debhelper-compat:any',
+ cli => 'cli-common-dev:any | dh-sequence-cli:any',
+ dwz => 'debhelper:any | debhelper-compat:any | dh-sequence-dwz:any',
+ installinitramfs =>
+'debhelper:any | debhelper-compat:any | dh-sequence-installinitramfs:any',
+ gnome => 'gnome-pkg-tools:any | dh-sequence-gnome:any',
+ lv2config => 'lv2core:any',
+ nodejs => 'pkg-js-tools:any | dh-sequence-nodejs:any',
+ perl_dbi => 'libdbi-perl:any | dh-sequence-perl-dbi:any',
+ perl_imager => 'libimager-perl:any | dh-sequence-perl-imager:any',
+ pgxs => 'postgresql-server-dev-all:any | postgresql-all:any',
+ pgxs_loop => 'postgresql-server-dev-all:any | postgresql-all:any',
+ pypy => 'dh-python:any | dh-sequence-pypy:any',
+ python2 => 'python2:any | python2-dev:any | dh-sequence-python2:any',
+ python3 =>
+'python3:any | python3-all:any | python3-dev:any | python3-all-dev:any | dh-sequence-python3:any',
+ scour => 'scour:any | python-scour:any | dh-sequence-scour:any',
+ sphinxdoc =>
+'sphinx:any | python-sphinx:any | python3-sphinx:any | dh-sequence-sphinxdoc:any',
+ systemd =>
+'debhelper:any (>= 9.20160709~) | debhelper-compat:any | dh-sequence-systemd:any | dh-systemd:any',
+ vim_addon => 'dh-vim-addon:any | dh-sequence-vim-addon:any',
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->dirname eq 'debian/';
+
+ return
+ if !$item->is_symlink && !$item->is_file;
+
+ if ( $item->basename eq 'control'
+ || $item->basename =~ m/^(?:.*\.)?(?:copyright|changelog|NEWS)$/) {
+
+ # Handle "control", [<pkg>.]copyright, [<pkg>.]changelog
+ # and [<pkg>.]NEWS
+
+ # The permissions of symlinks are not really defined, so resolve
+ # $item to ensure we are not dealing with a symlink.
+ my $actual = $item->resolve_path;
+
+ $self->pointed_hint('package-file-is-executable', $item->pointer)
+ if $actual && $actual->is_executable;
+
+ return;
+ }
+
+ return;
+}
+
+sub source {
+ my ($self) = @_;
+
+ my @MAINT_COMMANDS = @{$self->data->debhelper_commands->maint_commands};
+
+ my $FILENAME_CONFIGS= $self->data->load('debhelper/filename-config-files');
+
+ my $DEBHELPER_LEVELS = $self->data->debhelper_levels;
+ my $DH_ADDONS = $self->data->debhelper_addons;
+ my $DH_COMMANDS_DEPENDS= $self->data->debhelper_commands;
+
+ my @KNOWN_DH_COMMANDS;
+ for my $command ($DH_COMMANDS_DEPENDS->all) {
+ for my $focus ($EMPTY, qw(-arch -indep)) {
+ for my $timing (qw(override execute_before execute_after)) {
+
+ push(@KNOWN_DH_COMMANDS,
+ $timing . $UNDERSCORE . $command . $focus);
+ }
+ }
+ }
+
+ my $debhelper_level;
+ my $dh_compat_variable;
+ my $maybe_skipping;
+
+ my $uses_debhelper = 0;
+ my $uses_dh_exec = 0;
+ my $uses_autotools_dev_dh = 0;
+
+ my $includes_cdbs = 0;
+ my $modifies_scripts = 0;
+
+ my $seen_any_dh_command = 0;
+ my $seen_dh_sequencer = 0;
+ my $seen_dh_dynamic = 0;
+ my $seen_dh_systemd = 0;
+ my $seen_dh_parallel = 0;
+ my $seen_dh_clean_k = 0;
+
+ my %command_by_prerequisite;
+ my %addon_by_prerequisite;
+ my %overrides;
+
+ my $droot = $self->processable->patched->resolve_path('debian/');
+
+ my $drules;
+ $drules = $droot->child('rules') if $droot;
+
+ return
+ unless $drules && $drules->is_open_ok;
+
+ open(my $rules_fd, '<', $drules->unpacked_path)
+ or die encode_utf8('Cannot open ' . $drules->unpacked_path);
+
+ my $command_prefix_pattern = qr/\s+[@+-]?(?:\S+=\S+\s+)*/;
+
+ my $build_prerequisites_norestriction
+ = $self->processable->relation_norestriction('Build-Depends-All');
+ my $build_prerequisites= $self->processable->relation('Build-Depends-All');
+
+ my %seen = (
+ 'python2' => 0,
+ 'python3' => 0,
+ 'runit' => 0,
+ 'sphinxdoc' => 0,
+ );
+
+ for (qw(python2 python3)) {
+
+ $seen{$_} = 1
+ if $build_prerequisites_norestriction->satisfies(
+ "dh-sequence-$_:any");
+ }
+
+ my %build_systems;
+
+ my $position = 1;
+ while (my $line = <$rules_fd>) {
+
+ my $pointer = $drules->pointer($position);
+
+ while ($line =~ s/\\$// && defined(my $cont = <$rules_fd>)) {
+ $line .= $cont;
+ }
+
+ if ($line =~ /^ifn?(?:eq|def)\s/) {
+ $maybe_skipping++;
+
+ } elsif ($line =~ /^endif\s/) {
+ $maybe_skipping--;
+ }
+
+ next
+ if $line =~ /^\s*\#/;
+
+ if ($line =~ /^$command_prefix_pattern(dh_(?!autoreconf)\S+)/) {
+
+ my $dh_command = $1;
+
+ $build_systems{'debhelper'} = 1
+ unless exists $build_systems{'dh'};
+
+ $self->pointed_hint('dh_installmanpages-is-obsolete',$pointer)
+ if $dh_command eq 'dh_installmanpages';
+
+ if ( $dh_command eq 'dh_autotools-dev_restoreconfig'
+ || $dh_command eq 'dh_autotools-dev_updateconfig') {
+
+ $self->pointed_hint(
+ 'debhelper-tools-from-autotools-dev-are-deprecated',
+ $pointer, $dh_command);
+ $uses_autotools_dev_dh = 1;
+ }
+
+ # Record if we've seen specific helpers, special-casing
+ # "dh_python" as Python 2.x.
+ $seen{'python2'} = 1 if $dh_command eq 'dh_python2';
+ for my $k (keys %seen) {
+ $seen{$k} = 1 if $dh_command eq "dh_$k";
+ }
+
+ $seen_dh_clean_k = 1
+ if $dh_command eq 'dh_clean'
+ && $line =~ /\s+\-k(?:\s+.*)?$/s;
+
+ # if command is passed -n, it does not modify the scripts
+ $modifies_scripts = 1
+ if (any { $dh_command eq $_ } @MAINT_COMMANDS)
+ && $line !~ /\s+\-n\s+/;
+
+ # If debhelper commands are wrapped in make conditionals, assume the
+ # maintainer knows what they're doing and don't check build
+ # dependencies.
+ unless ($maybe_skipping) {
+
+ if (exists $DH_COMMAND_MANUAL_PREREQUISITES{$dh_command}) {
+ my $prerequisite
+ = $DH_COMMAND_MANUAL_PREREQUISITES{$dh_command};
+ $command_by_prerequisite{$prerequisite} = $dh_command;
+
+ } elsif ($DH_COMMANDS_DEPENDS->installed_by($dh_command)) {
+
+ my @broadened = map { "$_:any" }
+ $DH_COMMANDS_DEPENDS->installed_by($dh_command);
+ my $prerequisite
+ = join($SPACE . $HORIZONTAL_BAR . $SPACE,@broadened);
+ $command_by_prerequisite{$prerequisite} = $dh_command;
+ }
+ }
+
+ $seen_any_dh_command = 1;
+ $uses_debhelper = 1;
+
+ } elsif ($line =~ m{^(?:$command_prefix_pattern)dh\s+}) {
+
+ $build_systems{'dh'} = 1;
+ delete($build_systems{'debhelper'});
+
+ $seen_dh_sequencer = 1;
+ $seen_any_dh_command = 1;
+
+ $seen_dh_dynamic = 1
+ if $line =~ /\$[({]\w/;
+
+ $seen_dh_parallel = $position
+ if $line =~ /--parallel/;
+
+ $uses_debhelper = 1;
+ $modifies_scripts = 1;
+
+ while ($line =~ /\s--with(?:=|\s+)(['"]?)(\S+)\1/g) {
+
+ my $addon_list = $2;
+
+ for my $addon (split(/,/, $addon_list)) {
+
+ my $orig_addon = $addon;
+
+ $addon =~ y,-,_,;
+
+ my @broadened
+ = map { "$_:any" } $DH_ADDONS->installed_by($addon);
+ my $prerequisite = $DH_ADDON_MANUAL_PREREQUISITES{$addon}
+ || join($SPACE . $HORIZONTAL_BAR . $SPACE,@broadened);
+
+ if ($addon eq 'autotools_dev') {
+
+ $self->pointed_hint(
+'debhelper-tools-from-autotools-dev-are-deprecated',
+ $pointer,"dh ... --with $orig_addon"
+ );
+ $uses_autotools_dev_dh = 1;
+ }
+
+ $seen_dh_systemd = $position
+ if $addon eq 'systemd';
+
+ $self->pointed_hint(
+ 'dh-quilt-addon-but-quilt-source-format',
+ $pointer,"dh ... --with $orig_addon")
+ if $addon eq 'quilt'
+ && $self->processable->fields->value('Format') eq
+ '3.0 (quilt)';
+
+ $addon_by_prerequisite{$prerequisite} = $addon
+ if defined $prerequisite;
+
+ for my $k (keys %seen) {
+ $seen{$k} = 1
+ if $addon eq $k;
+ }
+ }
+ }
+
+ } elsif ($line =~ m{^include\s+/usr/share/cdbs/1/rules/debhelper.mk}
+ || $line =~ m{^include\s+/usr/share/R/debian/r-cran.mk}) {
+
+ $build_systems{'cdbs-with-debhelper.mk'} = 1;
+ delete($build_systems{'cdbs-without-debhelper.mk'});
+
+ $seen_any_dh_command = 1;
+ $uses_debhelper = 1;
+ $modifies_scripts = 1;
+ $includes_cdbs = 1;
+
+ # CDBS sets DH_COMPAT but doesn't export it.
+ $dh_compat_variable = $CDBS_COMPAT;
+
+ } elsif ($line =~ /^\s*export\s+DH_COMPAT\s*:?=\s*([^\s]+)/) {
+ $debhelper_level = $1;
+
+ } elsif ($line =~ /^\s*export\s+DH_COMPAT/) {
+ $debhelper_level = $dh_compat_variable
+ if $dh_compat_variable;
+
+ } elsif ($line =~ /^\s*DH_COMPAT\s*:?=\s*([^\s]+)/) {
+ $dh_compat_variable = $1;
+
+ # one can export and then set the value:
+ $debhelper_level = $1
+ if $debhelper_level;
+
+ } elsif (
+ $line =~ /^[^:]*(override|execute_(?:after|before))\s+(dh_[^:]*):/)
+ {
+ $self->pointed_hint('typo-in-debhelper-override-target',
+ $pointer, "$1 $2",$ARROW, "$1_$2");
+
+ } elsif ($line =~ /^([^:]*_dh_[^:]*):/) {
+
+ my $alltargets = $1;
+ # can be multiple targets per rule.
+ my @targets = split(/\s+/, $alltargets);
+ my @dh_targets = grep { /_dh_/ } @targets;
+
+ # If maintainer is using wildcards, it's unlikely to be a typo.
+ my @no_wildcards = grep { !/%/ } @dh_targets;
+
+ my $lc = List::Compare->new(\@no_wildcards, \@KNOWN_DH_COMMANDS);
+ my @unknown = $lc->get_Lonly;
+
+ for my $target (@unknown) {
+
+ my %distance
+ = map { $_ => distance($target, $_) } @KNOWN_DH_COMMANDS;
+ my @near = grep { $distance{$_} < $LEVENSHTEIN_TOLERANCE }
+ keys %distance;
+ my $nearest = min_by { $distance{$_} } @near;
+
+ $self->pointed_hint('typo-in-debhelper-override-target',
+ $pointer, $target, $ARROW, $nearest)
+ if length $nearest;
+ }
+
+ for my $target (@no_wildcards) {
+
+ next
+ unless $target
+ =~ /^(override|execute_(?:before|after))_dh_([^\s]+?)(-arch|-indep|)$/;
+
+ my $timing = $1;
+ my $command = $2;
+ my $focus = $3;
+ my $dh_command = "dh_$command";
+
+ $overrides{$dh_command} = [$position, $focus];
+ $uses_debhelper = 1;
+
+ next
+ if $DH_COMMANDS_DEPENDS->installed_by($dh_command);
+
+ # Unknown command, so check for likely misspellings
+ my $missingauto = firstval { "dh_auto_$command" eq $_ }
+ $DH_COMMANDS_DEPENDS->all;
+
+ $self->pointed_hint(
+ 'typo-in-debhelper-override-target',$pointer,
+ $timing . $UNDERSCORE . $dh_command,$ARROW,
+ $timing . $UNDERSCORE . $missingauto,
+ )if length $missingauto;
+ }
+
+ } elsif ($line =~ m{^include\s+/usr/share/cdbs/}) {
+
+ $includes_cdbs = 1;
+
+ $build_systems{'cdbs-without-debhelper.mk'} = 1
+ unless exists $build_systems{'cdbs-with-debhelper.mk'};
+
+ } elsif (
+ $line =~m{
+ ^include \s+
+ /usr/share/(?:
+ dh-php/pkg-pecl\.mk
+ |blends-dev/rules
+ )
+ }xsm
+ ) {
+ # All of these indirectly use dh.
+ $seen_any_dh_command = 1;
+ $build_systems{'dh'} = 1;
+ delete($build_systems{'debhelper'});
+
+ } elsif (
+ $line =~m{
+ ^include \s+
+ /usr/share/pkg-kde-tools/qt-kde-team/\d+/debian-qt-kde\.mk
+ }xsm
+ ) {
+
+ $includes_cdbs = 1;
+ $build_systems{'dhmk'} = 1;
+ delete($build_systems{'debhelper'});
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $rules_fd;
+
+ # Variables could contain any add-ons; assume we have seen them all
+ %seen = map { $_ => 1 } keys %seen
+ if $seen_dh_dynamic;
+
+ # Okay - d/rules does not include any file in /usr/share/cdbs/
+ $self->pointed_hint('unused-build-dependency-on-cdbs', $drules->pointer)
+ if $build_prerequisites->satisfies('cdbs:any')
+ && !$includes_cdbs;
+
+ if (%build_systems) {
+
+ my @systems = sort keys %build_systems;
+ $self->pointed_hint('debian-build-system', $drules->pointer,
+ join(', ', @systems));
+
+ } else {
+ $self->pointed_hint('debian-build-system', $drules->pointer, 'other');
+ }
+
+ unless ($seen_any_dh_command || $includes_cdbs) {
+
+ $self->pointed_hint('package-does-not-use-debhelper-or-cdbs',
+ $drules->pointer);
+ return;
+ }
+
+ my @installable_names= $self->processable->debian_control->installables;
+
+ for my $installable_name (@installable_names) {
+
+ next
+ if $self->processable->debian_control->installable_package_type(
+ $installable_name) ne 'deb';
+
+ my $strong
+ = $self->processable->binary_relation($installable_name, 'strong');
+ my $all= $self->processable->binary_relation($installable_name, 'all');
+
+ $self->hint('debhelper-but-no-misc-depends', $installable_name)
+ unless $all->satisfies($MISC_DEPENDS);
+
+ $self->hint('weak-dependency-on-misc-depends', $installable_name)
+ if $all->satisfies($MISC_DEPENDS)
+ && !$strong->satisfies($MISC_DEPENDS);
+ }
+
+ for my $installable ($self->group->get_installables) {
+
+ next
+ if $installable->type eq 'udeb';
+
+ my $breaks
+ = $self->processable->binary_relation($installable->name, 'Breaks');
+ my $strong
+ = $self->processable->binary_relation($installable->name, 'strong');
+
+ $self->pointed_hint('package-uses-dh-runit-but-lacks-breaks-substvar',
+ $drules->pointer,$installable->name)
+ if $seen{'runit'}
+ && $strong->satisfies('runit:any')
+ && (any { m{^ etc/sv/ }msx } @{$installable->installed->sorted_list})
+ && !$breaks->satisfies($DOLLAR . '{runit:Breaks}');
+ }
+
+ my $virtual_compat;
+
+ $build_prerequisites->visit(
+ sub {
+ return 0
+ unless
+ m{^ debhelper-compat (?: : \S+ )? \s+ [(]= \s+ (\d+) [)] $}x;
+
+ $virtual_compat = $1;
+
+ return 1;
+ },
+ Lintian::Relation::VISIT_PRED_FULL
+ | Lintian::Relation::VISIT_STOP_FIRST_MATCH
+ );
+
+ my $control_item=$self->processable->debian_control->item;
+
+ $self->pointed_hint('debhelper-compat-virtual-relation',
+ $control_item->pointer, $virtual_compat)
+ if length $virtual_compat;
+
+ # gives precedence to virtual compat
+ $debhelper_level = $virtual_compat
+ if length $virtual_compat;
+
+ my $compat_file = $droot->child('compat');
+
+ $self->hint('debhelper-compat-file-is-missing')
+ unless ($compat_file && $compat_file->is_open_ok)
+ || $virtual_compat;
+
+ my $from_compat_file = $self->check_compat_file;
+
+ if (length $debhelper_level && length $from_compat_file) {
+
+ $self->pointed_hint(
+ 'declares-possibly-conflicting-debhelper-compat-versions',
+ $compat_file->pointer,$from_compat_file,'vs elsewhere',
+ $debhelper_level);
+ }
+
+ # this is not just to fill in the gap, but because debhelper
+ # prefers DH_COMPAT over debian/compat
+ $debhelper_level ||= $from_compat_file;
+
+ $self->hint('debhelper-compat-level', $debhelper_level)
+ if length $debhelper_level;
+
+ $debhelper_level ||= 1;
+
+ $self->hint('package-uses-deprecated-debhelper-compat-version',
+ $debhelper_level)
+ if $debhelper_level < $DEBHELPER_LEVELS->value('deprecated');
+
+ $self->hint('package-uses-old-debhelper-compat-version', $debhelper_level)
+ if $debhelper_level >= $DEBHELPER_LEVELS->value('deprecated')
+ && $debhelper_level < $DEBHELPER_LEVELS->value('recommended');
+
+ $self->hint('package-uses-experimental-debhelper-compat-version',
+ $debhelper_level)
+ if $debhelper_level >= $DEBHELPER_LEVELS->value('experimental');
+
+ $self->pointed_hint('dh-clean-k-is-deprecated', $drules->pointer)
+ if $seen_dh_clean_k;
+
+ for my $suffix (qw(enable start)) {
+
+ my ($stored_position, $focus)
+ = @{$overrides{"dh_systemd_$suffix"} // []};
+
+ $self->pointed_hint(
+ 'debian-rules-uses-deprecated-systemd-override',
+ $drules->pointer($stored_position),
+ "override_dh_systemd_$suffix$focus"
+ )
+ if $stored_position
+ && $debhelper_level >= $BETTER_SYSTEMD_INTEGRATION;
+ }
+
+ my $num_overrides = scalar(keys %overrides);
+
+ $self->hint('excessive-debhelper-overrides', $num_overrides)
+ if $num_overrides >= $MANY_OVERRIDES;
+
+ $self->pointed_hint(
+ 'debian-rules-uses-unnecessary-dh-argument',
+ $drules->pointer($seen_dh_parallel),
+ "$debhelper_level >= $DH_PARALLEL_NOT_NEEDED",
+ 'dh ... --parallel'
+ )if $seen_dh_parallel && $debhelper_level >= $DH_PARALLEL_NOT_NEEDED;
+
+ $self->pointed_hint(
+ 'debian-rules-uses-unnecessary-dh-argument',
+ $drules->pointer($seen_dh_systemd),
+ "$debhelper_level >= $INVOKES_SYSTEMD",
+ 'dh ... --with=systemd'
+ )if $seen_dh_systemd && $debhelper_level >= $INVOKES_SYSTEMD;
+
+ for my $item ($droot->children) {
+
+ next
+ if !$item->is_symlink && !$item->is_file;
+
+ next
+ if $item->name eq $drules->name;
+
+ if ($item->basename =~ m/^(?:(.*)\.)?(?:post|pre)(?:inst|rm)$/) {
+
+ next
+ unless $modifies_scripts;
+
+ # They need to have #DEBHELPER# in their scripts. Search
+ # for scripts that look like maintainer scripts and make
+ # sure the token is there.
+ my $installable_name = $1 || $EMPTY;
+ my $seentag = 0;
+
+ $seentag = 1
+ if $item->decoded_utf8 =~ /\#DEBHELPER\#/;
+
+ if (!$seentag) {
+
+ my $single_pkg = $EMPTY;
+ $single_pkg
+ = $self->processable->debian_control
+ ->installable_package_type($installable_names[0])
+ if scalar @installable_names == 1;
+
+ my $installable_type
+ = $self->processable->debian_control
+ ->installable_package_type($installable_name);
+
+ my $is_udeb = 0;
+
+ $is_udeb = 1
+ if $installable_name && $installable_type eq 'udeb';
+
+ $is_udeb = 1
+ if !$installable_name && $single_pkg eq 'udeb';
+
+ $self->pointed_hint('maintainer-script-lacks-debhelper-token',
+ $item->pointer)
+ unless $is_udeb;
+ }
+
+ next;
+ }
+
+ my $category = $item->basename;
+ $category =~ s/^.+\.//;
+
+ next
+ unless length $category;
+
+ # Check whether this is a debhelper config file that takes
+ # a list of filenames.
+ if ($FILENAME_CONFIGS->recognizes($category)) {
+
+ # The permissions of symlinks are not really defined, so resolve
+ # $item to ensure we are not dealing with a symlink.
+ my $actual = $item->resolve_path;
+ next
+ unless defined $actual;
+
+ $self->check_for_brace_expansion($item, $debhelper_level);
+
+ # debhelper only use executable files in compat 9
+ $self->pointed_hint('package-file-is-executable', $item->pointer)
+ if $actual->is_executable
+ && $debhelper_level < $USES_EXECUTABLE_FILES;
+
+ if ($debhelper_level >= $USES_EXECUTABLE_FILES) {
+
+ $self->pointed_hint(
+ 'executable-debhelper-file-without-being-executable',
+ $item->pointer)
+ if $actual->is_executable
+ && !length $actual->hashbang;
+
+ # Only /usr/bin/dh-exec is allowed, even if
+ # /usr/lib/dh-exec/dh-exec-subst works too.
+ $self->pointed_hint('dh-exec-private-helper', $item->pointer)
+ if $actual->is_executable
+ && $actual->hashbang =~ m{^/usr/lib/dh-exec/};
+
+ # Do not make assumptions about the contents of an
+ # executable debhelper file, unless it's a dh-exec
+ # script.
+ if ($actual->hashbang =~ /dh-exec/) {
+
+ $uses_dh_exec = 1;
+ $self->check_dh_exec($item, $category);
+ }
+ }
+ }
+ }
+
+ $self->pointed_hint('package-uses-debhelper-but-lacks-build-depends',
+ $drules->pointer)
+ if $uses_debhelper
+ && !$build_prerequisites->satisfies('debhelper:any')
+ && !$build_prerequisites->satisfies('debhelper-compat:any');
+
+ $self->pointed_hint('package-uses-dh-exec-but-lacks-build-depends',
+ $drules->pointer)
+ if $uses_dh_exec
+ && !$build_prerequisites->satisfies('dh-exec:any');
+
+ for my $prerequisite (keys %command_by_prerequisite) {
+
+ my $command = $command_by_prerequisite{$prerequisite};
+
+ # handled above
+ next
+ if $prerequisite eq 'debhelper:any';
+
+ next
+ if $debhelper_level >= $REQUIRES_AUTOTOOLS
+ && (any { $_ eq $prerequisite }
+ qw(autotools-dev:any dh-strip-nondeterminism:any));
+
+ $self->pointed_hint('missing-build-dependency-for-dh_-command',
+ $drules->pointer,$command, "(does not satisfy $prerequisite)")
+ unless $build_prerequisites_norestriction->satisfies($prerequisite);
+ }
+
+ for my $prerequisite (keys %addon_by_prerequisite) {
+
+ my $addon = $addon_by_prerequisite{$prerequisite};
+
+ next
+ if $debhelper_level >= $REQUIRES_AUTOTOOLS
+ && $addon eq 'autoreconf';
+
+ $self->pointed_hint('missing-build-dependency-for-dh-addon',
+ $drules->pointer,$addon, "(does not satisfy $prerequisite)")
+ unless (
+ $build_prerequisites_norestriction->satisfies($prerequisite));
+
+ # As a special case, the python3 addon needs a dependency on
+ # dh-python unless the -dev packages are used.
+ my $python_source
+ = 'dh-python:any | dh-sequence-python3:any | pybuild-plugin-pyproject:any';
+
+ $self->pointed_hint('missing-build-dependency-for-dh-addon',
+ $drules->pointer,$addon, "(does not satisfy $python_source)")
+ if $addon eq 'python3'
+ && $build_prerequisites_norestriction->satisfies($prerequisite)
+ && !$build_prerequisites_norestriction->satisfies(
+ 'python3-dev:any | python3-all-dev:any')
+ && !$build_prerequisites_norestriction->satisfies($python_source);
+ }
+
+ $self->hint('no-versioned-debhelper-prerequisite', $debhelper_level)
+ unless $build_prerequisites->satisfies(
+ "debhelper:any (>= $debhelper_level~)")
+ || $build_prerequisites->satisfies(
+ "debhelper-compat:any (= $debhelper_level)");
+
+ if ($debhelper_level >= $USES_AUTORECONF) {
+ for my $autotools_source (qw(dh-autoreconf:any autotools-dev:any)) {
+
+ next
+ if $autotools_source eq 'autotools-dev:any'
+ && $uses_autotools_dev_dh;
+
+ $self->hint('useless-autoreconf-build-depends',
+ "(does not need to satisfy $autotools_source)")
+ if $build_prerequisites->satisfies($autotools_source);
+ }
+ }
+
+ if ($seen_dh_sequencer && !$seen{'python2'}) {
+
+ my %python_depends;
+
+ for my $installable_name (@installable_names) {
+
+ $python_depends{$installable_name} = 1
+ if $self->processable->binary_relation($installable_name,'all')
+ ->satisfies($DOLLAR . '{python:Depends}');
+ }
+
+ $self->hint('python-depends-but-no-python-helper',
+ (sort keys %python_depends))
+ if %python_depends;
+ }
+
+ if ($seen_dh_sequencer && !$seen{'python3'}) {
+
+ my %python3_depends;
+
+ for my $installable_name (@installable_names) {
+
+ $python3_depends{$installable_name} = 1
+ if $self->processable->binary_relation($installable_name,'all')
+ ->satisfies($DOLLAR . '{python3:Depends}');
+ }
+
+ $self->hint('python3-depends-but-no-python3-helper',
+ (sort keys %python3_depends))
+ if %python3_depends;
+ }
+
+ if ($seen{'sphinxdoc'} && !$seen_dh_dynamic) {
+
+ my $seen_sphinxdoc = 0;
+
+ for my $installable_name (@installable_names) {
+ $seen_sphinxdoc = 1
+ if $self->processable->binary_relation($installable_name,'all')
+ ->satisfies($DOLLAR . '{sphinxdoc:Depends}');
+ }
+
+ $self->pointed_hint('sphinxdoc-but-no-sphinxdoc-depends',
+ $drules->pointer)
+ unless $seen_sphinxdoc;
+ }
+
+ return;
+}
+
+sub check_for_brace_expansion {
+ my ($self, $item, $debhelper_level) = @_;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ if $line =~ /^\s*$/;
+
+ next
+ if $line =~ /^\#/
+ && $debhelper_level >= $BRACE_EXPANSION;
+
+ if ($line =~ /((?<!\\)\{(?:[^\s\\\}]*?,)+[^\\\}\s,]*,*\})/){
+ my $expansion = $1;
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('brace-expansion-in-debhelper-config-file',
+ $pointer, $expansion);
+
+ last;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+sub check_compat_file {
+ my ($self) = @_;
+
+ # Check the compat file. Do this separately from looping over all
+ # of the other files since we use the compat value when checking
+ # for brace expansion.
+
+ my $compat_file
+ = $self->processable->patched->resolve_path('debian/compat');
+
+ # missing file is dealt with elsewhere
+ return $EMPTY
+ unless $compat_file && $compat_file->is_open_ok;
+
+ my $debhelper_level;
+
+ open(my $fd, '<', $compat_file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $compat_file->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ if ($position == 1) {
+
+ $debhelper_level = $line;
+ next;
+ }
+
+ my $pointer = $compat_file->pointer($position);
+
+ $self->pointed_hint('debhelper-compat-file-contains-multiple-levels',
+ $pointer)
+ if $line =~ /^\d/;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ # trim both ends
+ $debhelper_level =~ s/^\s+|\s+$//g;
+
+ if (!length $debhelper_level) {
+
+ $self->pointed_hint('debhelper-compat-file-is-empty',
+ $compat_file->pointer);
+ return $EMPTY;
+ }
+
+ my $DEBHELPER_LEVELS = $self->data->debhelper_levels;
+
+ # Recommend people use debhelper-compat (introduced in debhelper
+ # 11.1.5~alpha1) over debian/compat, except for experimental/beta
+ # versions.
+ $self->pointed_hint('uses-debhelper-compat-file', $compat_file->pointer)
+ if $debhelper_level >= $VERSIONED_PREREQUISITE_AVAILABLE
+ && $debhelper_level < $DEBHELPER_LEVELS->value('experimental');
+
+ return $debhelper_level;
+}
+
+sub check_dh_exec {
+ my ($self, $item, $category) = @_;
+
+ return
+ unless $item->is_open_ok;
+
+ my $dhe_subst = 0;
+ my $dhe_install = 0;
+ my $dhe_filter = 0;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my $pointer = $item->pointer($position);
+
+ if ($line =~ /\$\{([^\}]+)\}/) {
+
+ my $sv = $1;
+ $dhe_subst = 1;
+
+ if (
+ $sv !~ m{ \A
+ DEB_(?:BUILD|HOST)_(?:
+ ARCH (?: _OS|_CPU|_BITS|_ENDIAN )?
+ |GNU_ (?:CPU|SYSTEM|TYPE)|MULTIARCH
+ ) \Z}xsm
+ ) {
+ $self->pointed_hint('dh-exec-subst-unknown-variable',
+ $pointer, $sv);
+ }
+ }
+
+ $dhe_install = 1
+ if $line =~ /[ \t]=>[ \t]/;
+
+ $dhe_filter = 1
+ if $line =~ /\[[^\]]+\]/;
+
+ $dhe_filter = 1
+ if $line =~ /<[^>]+>/;
+
+ if ( $line =~ /^usr\/lib\/\$\{([^\}]+)\}\/?$/
+ || $line
+ =~ /^usr\/lib\/\$\{([^\}]+)\}\/?\s+\/usr\/lib\/\$\{([^\}]+)\}\/?$/
+ || $line =~ /^usr\/lib\/\$\{([^\}]+)\}[^\s]+$/) {
+
+ my $sv = $1;
+ my $dv = $2;
+ my $dhe_useless = 0;
+
+ if (
+ $sv =~ m{ \A
+ DEB_(?:BUILD|HOST)_(?:
+ ARCH (?: _OS|_CPU|_BITS|_ENDIAN )?
+ |GNU_ (?:CPU|SYSTEM|TYPE)|MULTIARCH
+ ) \Z}xsm
+ ) {
+ if (defined($dv)) {
+ $dhe_useless = ($sv eq $dv);
+ } else {
+ $dhe_useless = 1;
+ }
+ }
+
+ $self->pointed_hint('dh-exec-useless-usage', $pointer, $line)
+ if $dhe_useless && $item =~ /debian\/.*(install|manpages)/;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ $self->pointed_hint('dh-exec-script-without-dh-exec-features',
+ $item->pointer)
+ if !$dhe_subst
+ && !$dhe_install
+ && !$dhe_filter;
+
+ $self->pointed_hint('dh-exec-install-not-allowed-here', $item->pointer)
+ if $dhe_install
+ && $category ne 'install'
+ && $category ne 'manpages';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debhelper/Temporary.pm b/lib/Lintian/Check/Debhelper/Temporary.pm
new file mode 100644
index 0000000..452d76c
--- /dev/null
+++ b/lib/Lintian/Check/Debhelper/Temporary.pm
@@ -0,0 +1,55 @@
+# debhelper/temporary -- lintian check script -*- perl -*-
+
+# Copyright (C) 1999 by Joey Hess
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debhelper::Temporary;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->dirname eq 'debian/';
+
+ # The regex matches "debhelper", but debhelper/Dh_Lib does not
+ # make those, so skip it.
+ $self->pointed_hint('temporary-debhelper-file', $item->pointer)
+ if $item->basename =~ m{ (?: ^ | [.] ) debhelper (?: [.]log )? $}x
+ && $item->basename ne 'debhelper';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Changelog.pm b/lib/Lintian/Check/Debian/Changelog.pm
new file mode 100644
index 0000000..faa7890
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Changelog.pm
@@ -0,0 +1,970 @@
+# debian/changelog -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Changelog;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Data::Validate::Domain;
+use Date::Format qw(time2str);
+use Email::Address::XS;
+use List::Util qw(first);
+use List::SomeUtils qw(any all uniq);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Changelog;
+use Lintian::Changelog::Version;
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Relation::Version qw(versions_gt);
+use Lintian::Spelling qw(check_spelling);
+
+const my $EMPTY => q{};
+const my $DOUBLE_QUOTE => q{"};
+const my $GREATER_THAN => q{>};
+const my $APPROXIMATELY_EQUAL => q{~};
+
+const my $NOT_EQUALS => q{!=};
+const my $ARROW => q{->};
+
+const my $MAXIMUM_WIDTH => 82;
+const my $FIRST_ARCHIVED_BUG_NUMBER => 50_004;
+const my $OUT_OF_REACH_BUG_NUMBER => 1_500_000;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $item, @orig_args) = @_;
+
+ my $pointer = $item->pointer($.);
+
+ return sub {
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+sub source {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my $changelog = $processable->changelog;
+ return
+ unless defined $changelog;
+
+ my @entries = @{$changelog->entries};
+ return
+ unless @entries;
+
+ my $latest_entry = $entries[0];
+
+ my $changelog_item = $self->processable->changelog_item;
+ my $latest_pointer = $changelog_item->pointer($latest_entry->position);
+
+ my $changes = $group->changes;
+ if ($changes) {
+ my $contents = path($changes->path)->slurp;
+ # make sure dot matches newlines, as well
+ if ($contents =~ qr/BEGIN PGP SIGNATURE.*END PGP SIGNATURE/ms) {
+
+ $self->pointed_hint('unreleased-changelog-distribution',
+ $latest_pointer)
+ if $latest_entry->Distribution eq 'UNRELEASED';
+ }
+ }
+
+ my $versionstring = $processable->fields->value('Version');
+ my $latest_version = Lintian::Changelog::Version->new;
+
+ try {
+ $latest_version->assign($versionstring, $processable->native);
+
+ } catch {
+ my $indicator= ($processable->native ? $EMPTY : 'non-') . 'native';
+ $self->pointed_hint('malformed-debian-changelog-version',
+ $latest_pointer,$versionstring, "(for $indicator)");
+ undef $latest_version;
+
+ # perlcritic 1.140-1 requires a semicolon on the next line
+ };
+
+ if (defined $latest_version) {
+
+ $self->pointed_hint(
+ 'hyphen-in-upstream-part-of-debian-changelog-version',
+ $latest_pointer,$latest_version->upstream)
+ if !$processable->native && $latest_version->upstream =~ qr/-/;
+
+ # unstable, testing, and stable shouldn't be used in Debian
+ # version numbers. unstable should get a normal version
+ # increment and testing and stable should get suite-specific
+ # versions.
+ #
+ # NMUs get a free pass because they need to work with the
+ # version number that was already there.
+ unless (length $latest_version->source_nmu) {
+ my $revision = $latest_version->maintainer_revision;
+ my $distribution = $latest_entry->Distribution;
+
+ $self->pointed_hint('version-refers-to-distribution',
+ $latest_pointer,$latest_version->literal)
+ if ($revision =~ /testing|(?:un)?stable/i)
+ || (
+ ($distribution eq 'unstable'|| $distribution eq 'experimental')
+ && $revision
+ =~ /woody|sarge|etch|lenny|squeeze|stretch|buster/);
+ }
+
+ my $examine = $latest_version->maintainer_revision;
+ $examine = $latest_version->upstream
+ unless $processable->native;
+
+ my $candidate_pattern = qr/rc|alpha|beta|pre(?:view|release)?/;
+ my $increment_pattern = qr/[^a-z].*|\Z/;
+
+ my ($candidate_string, $increment_string)
+ = ($examine =~ m/[^~a-z]($candidate_pattern)($increment_pattern)/sm);
+ if (length $candidate_string && !length $latest_version->source_nmu) {
+
+ $increment_string //= $EMPTY;
+
+ # remove rc-part and any preceding symbol
+ my $expected = $examine;
+ $expected =~ s/[\.\+\-\:]?\Q$candidate_string\E.*//;
+
+ my $suggestion = "$expected~$candidate_string$increment_string";
+
+ $self->pointed_hint(
+ 'rc-version-greater-than-expected-version',
+ $latest_pointer,
+ $examine,
+ $GREATER_THAN,
+ $expected,
+ "(consider using $suggestion)",
+ )
+ if $latest_version->maintainer_revision eq '1'
+ || $latest_version->maintainer_revision=~ /^0(?:\.1|ubuntu1)?$/
+ || $processable->native;
+ }
+ }
+
+ if (@entries > 1) {
+
+ my $previous_entry = $entries[1];
+ my $latest_timestamp = $latest_entry->Timestamp;
+ my $previous_timestamp = $previous_entry->Timestamp;
+
+ my $previous_version = Lintian::Changelog::Version->new;
+ try {
+ $previous_version->assign($previous_entry->Version,
+ $processable->native);
+ } catch {
+ my $indicator= ($processable->native ? $EMPTY : 'non-') . 'native';
+ $self->pointed_hint(
+ 'odd-historical-debian-changelog-version',
+ $changelog_item->pointer($previous_entry->position),
+ $previous_entry->Version,
+ "(for $indicator)"
+ );
+ undef $previous_version;
+ }
+
+ if ($latest_timestamp && $previous_timestamp) {
+
+ $self->pointed_hint(
+ 'latest-debian-changelog-entry-without-new-date',
+ $latest_pointer)
+ if $latest_timestamp <= $previous_timestamp
+ && lc($latest_entry->Distribution) ne 'unreleased';
+ }
+
+ if (defined $latest_version) {
+
+ # skip first
+ for my $entry (@entries[1..$#entries]) {
+
+ # cannot use parser; nativeness may differ
+ my ($no_epoch) = ($entry->Version =~ qr/^(?:[^:]+:)?([^:]+)$/);
+
+ next
+ unless defined $no_epoch;
+
+ # disallowed even if epochs differ; see tag description
+ if ( $latest_version->no_epoch eq $no_epoch
+ && $latest_entry->Source eq $entry->Source) {
+
+ $self->pointed_hint(
+'latest-debian-changelog-entry-reuses-existing-version',
+ $latest_pointer,
+ $latest_version->literal,
+ $APPROXIMATELY_EQUAL,
+ $entry->Version,
+ '(last used: '. $entry->Date . ')'
+ );
+
+ last;
+ }
+ }
+ }
+
+ if (defined $latest_version && defined $previous_version) {
+
+ # a reused version literal is caught by the broader previous check
+
+ # start with a reasonable default
+ my $expected_previous = $previous_version->literal;
+
+ $expected_previous = $latest_version->without_backport
+ if $latest_version->backport_release
+ && $latest_version->backport_revision
+ && $latest_version->debian_without_backport ne '0';
+
+ # find an appropriate prior version for a source NMU
+ if (length $latest_version->source_nmu) {
+
+ # can only do first nmu for now
+ $expected_previous = $latest_version->without_source_nmu
+ if $latest_version->source_nmu eq '1'
+ &&$latest_version->maintainer_revision =~ qr/\d+/
+ && $latest_version->maintainer_revision ne '0';
+ }
+
+ $self->pointed_hint(
+ 'changelog-file-missing-explicit-entry',$latest_pointer,
+ $previous_version->literal, $ARROW,
+ "$expected_previous (missing)", $ARROW,
+ $latest_version->literal
+ )
+ unless $previous_version->literal eq $expected_previous
+ || $latest_entry->Distribution eq 'bullseye'
+ || $previous_entry->Distribution eq 'bullseye'
+ || $latest_entry->Distribution =~ /-security$/i;
+
+ if ( $latest_version->epoch eq $previous_version->epoch
+ && $latest_version->upstream eq$previous_version->upstream
+ && $latest_entry->Source eq $previous_entry->Source
+ && !$processable->native) {
+
+ $self->pointed_hint(
+ 'possible-new-upstream-release-without-new-version',
+ $latest_pointer)
+ if $latest_entry->Changes
+ =~ /^\s*\*\s+new\s+upstream\s+(?:\S+\s+)?release\b/im;
+
+ my $non_consecutive = 0;
+
+ $non_consecutive = 1
+ if !length $latest_version->source_nmu
+ && $latest_version->maintainer_revision =~ /^\d+$/
+ && $previous_version->maintainer_revision =~ /^\d+$/
+ && $latest_version->maintainer_revision
+ != $previous_version->maintainer_revision + 1;
+
+ $non_consecutive = 1
+ if $latest_version->maintainer_revision eq
+ $previous_version->maintainer_revision
+ && $latest_version->source_nmu =~ /^\d+$/
+ && $previous_version->source_nmu =~ /^\d+$/
+ && $latest_version->source_nmu
+ != $previous_version->source_nmu + 1;
+
+ $non_consecutive = 1
+ if $latest_version->source_nmu =~ /^\d+$/
+ && !length $previous_version->source_nmu
+ && $latest_version->source_nmu != 1;
+
+ $self->pointed_hint(
+ 'non-consecutive-debian-revision',
+ $latest_pointer,$previous_version->literal,
+ $ARROW,$latest_version->literal
+ )if $non_consecutive;
+ }
+
+ if ($latest_version->epoch ne $previous_version->epoch) {
+ $self->pointed_hint(
+ 'epoch-change-without-comment',$latest_pointer,
+ $previous_version->literal, $ARROW,
+ $latest_version->literal
+ )unless $latest_entry->Changes =~ /\bepoch\b/im;
+
+ $self->pointed_hint(
+ 'epoch-changed-but-upstream-version-did-not-go-backwards',
+ $latest_pointer,$previous_version->literal,
+ $ARROW,$latest_version->literal
+ )
+ unless $processable->native
+ || versions_gt($previous_version->upstream,
+ $latest_version->upstream);
+ }
+ }
+ }
+
+ return;
+}
+
+# no copyright in udebs
+sub binary {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my $is_symlink = 0;
+ my $native_pkg;
+ my $foreign_pkg;
+ my @doc_files;
+
+ # skip packages which have a /usr/share/doc/$pkg -> foo symlink
+ my $docfile = $processable->installed->lookup("usr/share/doc/$pkg");
+ return
+ if defined $docfile && $docfile->is_symlink;
+
+ # trailing slash in indicates a directory
+ my $docdir = $processable->installed->lookup("usr/share/doc/$pkg/");
+ @doc_files = grep { $_->is_file || $_->is_symlink } $docdir->children
+ if defined $docdir;
+ my @news_files
+ = grep { $_->basename =~ m{\A NEWS\.Debian (?:\.gz)? \Z}ixsm }@doc_files;
+
+ $self->pointed_hint('debian-news-file-not-compressed', $_->pointer)
+ for grep { $_->basename !~ m{\.gz$} } @news_files;
+
+ $self->pointed_hint('wrong-name-for-debian-news-file', $_->pointer)
+ for grep { $_->basename =~ m{\.gz$} && $_->basename ne 'NEWS.Debian.gz' }
+ @news_files;
+
+ my @changelog_files = grep {
+ $_->basename =~ m{\A changelog (?:\.html|\.Debian)? (?:\.gz)? \Z}xsm
+ } @doc_files;
+
+ # ubuntu permits symlinks; their profile suppresses the tag
+ $self->pointed_hint('debian-changelog-file-is-a-symlink', $_->pointer)
+ for grep { $_->is_symlink } @changelog_files;
+
+ $self->pointed_hint('changelog-file-not-compressed', $_->pointer)
+ for grep { $_->basename !~ m{ \.gz \Z}xsm } @changelog_files;
+
+ # Check if changelog files are compressed with gzip -9.
+ # It's a bit of an open question here what we should do
+ # with a file named ChangeLog. If there's also a
+ # changelog file, it might be a duplicate, or the packager
+ # may have installed NEWS as changelog intentionally.
+ for my $item (@changelog_files) {
+
+ next
+ unless $item->basename =~ m{ \.gz \Z}xsm;
+
+ my $resolved = $item->resolve_path;
+ next
+ unless defined $resolved;
+
+ $self->pointed_hint('changelog-not-compressed-with-max-compression',
+ $item->pointer)
+ unless $resolved->file_type =~ /max compression/;
+ }
+
+ my @html_changelogs
+ = grep { $_->basename =~ /^changelog\.html(?:\.gz)?$/ } @changelog_files;
+ my @text_changelogs
+ = grep { $_->basename =~ /^changelog(?:\.gz)?$/ } @changelog_files;
+
+ if (!@text_changelogs) {
+
+ $self->pointed_hint('html-changelog-without-text-version', $_->pointer)
+ for @html_changelogs;
+ }
+
+ my $packagepath = 'usr/share/doc/' . $self->processable->name;
+ my $news_item
+ = $self->processable->installed->resolve_path(
+ "$packagepath/NEWS.Debian.gz");
+
+ my $news;
+ if (defined $news_item && $news_item->is_file) {
+
+ my $bytes = safe_qx('gunzip', '-c', $news_item->unpacked_path);
+
+ # another check complains about invalid encoding
+ if (valid_utf8($bytes)) {
+
+ my $contents = decode_utf8($bytes);
+ my $newslog = Lintian::Changelog->new;
+ $newslog->parse($contents);
+
+ for my $error (@{$newslog->errors}) {
+
+ my $position = $error->[0];
+ my $condition = $error->[1];
+
+ my $pointer = $news_item->pointer($position);
+
+ $self->pointed_hint('syntax-error-in-debian-news-file',
+ $pointer, $DOUBLE_QUOTE . $condition . $DOUBLE_QUOTE);
+ }
+
+ # Some checks on the most recent entry.
+ if ($newslog->entries && defined @{$newslog->entries}[0]) {
+
+ $news = @{$newslog->entries}[0];
+
+ my $pointer = $news_item->pointer($news->position);
+
+ $self->pointed_hint(
+ 'debian-news-entry-has-strange-distribution',
+ $pointer,$news->Distribution)
+ if length $news->Distribution
+ && $news->Distribution eq 'UNRELEASED';
+
+ check_spelling(
+ $self->data,
+ $news->Changes,
+ $group->spelling_exceptions,
+ $self->spelling_tag_emitter(
+ 'spelling-error-in-news-debian', $news_item
+ )
+ );
+
+ $self->pointed_hint('debian-news-entry-uses-asterisk',$pointer)
+ if $news->Changes =~ /^ \s* [*] \s /x;
+ }
+ }
+ }
+
+ # is this a native Debian package?
+ # If the version is missing, we assume it to be non-native
+ # as it is the most likely case.
+ my $source = $processable->fields->value('Source');
+ my $source_version;
+ if ($processable->fields->declares('Source') && $source =~ m/\((.*)\)/) {
+ $source_version = $1;
+ } else {
+ $source_version = $processable->fields->value('Version');
+ }
+ if (defined $source_version) {
+ $native_pkg = ($source_version !~ m/-/);
+ } else {
+ # We do not know, but assume it to non-native as it is
+ # the most likely case.
+ $native_pkg = 0;
+ }
+ $source_version = $processable->fields->value('Version') || '0-1';
+ $foreign_pkg = (!$native_pkg && $source_version !~ m/-0\./);
+ # A version of 1.2.3-0.1 could be either, so in that
+ # case, both vars are false
+
+ if ($native_pkg) {
+ # native Debian package
+ if (any { m/^changelog(?:\.gz)?$/} map { $_->basename } @doc_files) {
+ # everything is fine
+ } elsif (my $chg
+ = first {$_->basename =~ m/^changelog[.]debian(?:\.gz)$/i;}
+ @doc_files) {
+ $self->pointed_hint('wrong-name-for-changelog-of-native-package',
+ $chg->pointer);
+
+ } else {
+ $self->hint(
+ 'no-changelog',
+ "usr/share/doc/$pkg/changelog.gz",
+ '(native package)'
+ );
+ }
+ } else {
+ # non-native (foreign :) Debian package
+
+ # 1. check for upstream changelog
+ my $found_upstream_text_changelog = 0;
+ if (
+ any { m/^changelog(\.html)?(?:\.gz)?$/ }
+ map { $_->basename } @doc_files
+ ) {
+ $found_upstream_text_changelog = 1 unless $1;
+ # everything is fine
+ } else {
+ # search for changelogs with wrong file name
+ for my $item (@doc_files) {
+
+ if ( $item->basename =~ m/^change/i
+ && $item->basename !~ m/debian/i) {
+
+ $self->pointed_hint('wrong-name-for-upstream-changelog',
+ $item->pointer);
+ last;
+ }
+ }
+ }
+
+ # 2. check for Debian changelog
+ if (
+ any { m/^changelog\.Debian(?:\.gz)?$/ }
+ map { $_->basename } @doc_files
+ ) {
+ # everything is fine
+ } elsif (my $chg
+ = first {$_->basename =~ m/^changelog\.debian(?:\.gz)?$/i;}
+ @doc_files) {
+ $self->pointed_hint('wrong-name-for-debian-changelog-file',
+ $chg->pointer);
+
+ } else {
+ if ($foreign_pkg && $found_upstream_text_changelog) {
+ $self->hint('debian-changelog-file-missing-or-wrong-name');
+
+ } elsif ($foreign_pkg) {
+ $self->hint(
+ 'no-changelog',
+ "usr/share/doc/$pkg/changelog.Debian.gz",
+ '(non-native package)'
+ );
+ }
+ # TODO: if uncertain whether foreign or native, either
+ # changelog.gz or changelog.debian.gz should exists
+ # though... but no tests catches this (extremely rare)
+ # border case... Keep in mind this is only happening if we
+ # have a -0.x version number... So not my priority to fix
+ # --Jeroen
+ }
+ }
+
+ my $changelog_item = $self->processable->changelog_item;
+ return
+ unless defined $changelog_item;
+
+ # another check complains about invalid encoding
+ my $changelog = $processable->changelog;
+
+ for my $error (@{$changelog->errors}) {
+
+ my $position = $error->[0];
+ my $condition = $error->[1];
+
+ my $pointer = $changelog_item->pointer($position);
+
+ $self->pointed_hint('syntax-error-in-debian-changelog',
+ $pointer, $DOUBLE_QUOTE . $condition . $DOUBLE_QUOTE);
+ }
+
+ # Check for some things in the raw changelog file and compute the
+ # "offset" to the first line of the first entry. We use this to
+ # report the line number of "too-long" lines. (#657402)
+ my $real_start = $self->check_dch($changelog_item);
+
+ my @entries = @{$changelog->entries};
+
+ # all versions from the changelog
+ my %allversions
+ = map { $_ => 1 } grep { defined } map { $_->Version } @entries;
+
+ # checks applying to all entries
+ for my $entry (@entries) {
+
+ my $position = $entry->position;
+ my $version = $entry->Version;
+
+ my $pointer = $changelog_item->pointer($position);
+
+ if (length $entry->Maintainer) {
+ my ($parsed) = Email::Address::XS->parse($entry->Maintainer);
+
+ unless ($parsed->is_valid) {
+
+ $self->pointed_hint(
+ 'bogus-mail-host-in-debian-changelog',
+ $pointer,$entry->Maintainer,"(for version $version)",
+ );
+ next;
+ }
+
+ unless (all { length }
+ ($parsed->address, $parsed->user, $parsed->host)) {
+ $self->pointed_hint(
+ 'bogus-mail-host-in-debian-changelog',
+ $pointer,$parsed->format,"(for version $version)",
+ );
+ next;
+ }
+
+ $self->pointed_hint(
+ 'bogus-mail-host-in-debian-changelog',
+ $pointer, $parsed->address,"(for version $version)",
+ )
+ unless is_domain($parsed->host,
+ {domain_disable_tld_validation => 1});
+ }
+ }
+
+ my $INVALID_DATES
+ = $self->data->load('changelog-file/invalid-dates',qr/\s*=\>\s*/);
+
+ if (@entries) {
+
+ # checks related to the latest entry
+ my $latest_entry = $entries[0];
+
+ my $latest_pointer = $changelog_item->pointer($latest_entry->position);
+
+ my $latest_timestamp = $latest_entry->Timestamp;
+
+ if ($latest_timestamp) {
+
+ my $warned = 0;
+ my $longdate = $latest_entry->Date;
+
+ for my $re ($INVALID_DATES->all()) {
+ if ($longdate =~ m/($re)/i) {
+
+ my $match = $1;
+ my $repl = $INVALID_DATES->value($re);
+
+ $self->pointed_hint('invalid-date-in-debian-changelog',
+ $latest_pointer,"($match", $ARROW, "$repl)");
+
+ $warned = 1;
+ }
+ }
+
+ my ($weekday_declared, $numberportion)
+ = split(m/,\s*/, $longdate, 2);
+ $numberportion //= $EMPTY;
+ my ($tz, $weekday_actual);
+
+ if ($numberportion =~ m/[ ]+ ([^ ]+)\Z/xsm) {
+ $tz = $1;
+ $weekday_actual = time2str('%a', $latest_timestamp, $tz);
+ }
+
+ if (not $warned and $tz and $weekday_declared ne $weekday_actual) {
+ my $real_weekday = time2str('%A', $latest_timestamp, $tz);
+ my $short_date = time2str('%Y-%m-%d', $latest_timestamp, $tz);
+ $self->pointed_hint('debian-changelog-has-wrong-day-of-week',
+ $latest_pointer,"$short_date was a $real_weekday");
+ }
+ }
+
+ # there is more than one changelog entry
+ if (@entries > 1) {
+
+ my $previous_entry = $entries[1];
+
+ my $previous_timestamp = $previous_entry->Timestamp;
+
+ $self->pointed_hint('latest-changelog-entry-without-new-date',
+ $latest_pointer)
+ if defined $latest_timestamp
+ && defined $previous_timestamp
+ && $latest_timestamp <= $previous_timestamp
+ && $latest_entry->Distribution ne 'UNRELEASED';
+
+ my $latest_dist = lc $latest_entry->Distribution;
+ my $previous_dist = lc $previous_entry->Distribution;
+
+ $self->pointed_hint('experimental-to-unstable-without-comment',
+ $latest_pointer)
+ if $latest_dist eq 'unstable'
+ && $previous_dist eq 'experimental'
+ && $latest_entry->Changes
+ !~ m{ \b to \s+ ['"\N{LEFT SINGLE QUOTATION MARK}\N{LEFT DOUBLE QUOTATION MARK}]? (?:unstable|sid) ['"\N{RIGHT SINGLE QUOTATION MARK}\N{RIGHT DOUBLE QUOTATION MARK}]? \b }imx;
+
+ my $changes = $group->changes;
+ if ($changes) {
+ my $changes_dist= lc $changes->fields->value('Distribution');
+
+ my %codename;
+ $codename{'unstable'} = 'sid';
+ my @normalized
+ = uniq map { $codename{$_} // $_ }
+ ($latest_dist, $changes_dist);
+
+ $self->pointed_hint(
+ 'changelog-distribution-does-not-match-changes-file',
+ $latest_pointer,$latest_dist,
+ $NOT_EQUALS, $changes_dist
+ )unless @normalized == 1;
+ }
+
+ }
+
+ # Some checks should only be done against the most recent
+ # changelog entry.
+ my $changes = $latest_entry->Changes || $EMPTY;
+
+ if (@entries == 1) {
+
+ if ($latest_entry->Version && $latest_entry->Version =~ /-1$/) {
+ $self->pointed_hint('initial-upload-closes-no-bugs',
+ $latest_pointer)
+ unless @{ $latest_entry->Closes };
+
+ $self->pointed_hint(
+ 'new-package-uses-date-based-version-number',
+ $latest_pointer,
+ $latest_entry->Version,
+ '(better: 0~' . $latest_entry->Version .')'
+ )if $latest_entry->Version =~ m/^\d{8}/;
+ }
+
+ $self->pointed_hint('changelog-is-dh_make-template',
+ $latest_pointer)
+ if $changes
+ =~ /(?:#?\s*)(?:\d|n)+ is the bug number of your ITP/i;
+ }
+
+ while ($changes =~ /(closes[\s;]*(?:bug)?\#?\s?\d{6,})[^\w]/ig) {
+
+ my $closes = $1;
+
+ $self->pointed_hint('possible-missing-colon-in-closes',
+ $latest_pointer, $closes)
+ if length $closes;
+ }
+
+ if ($changes =~ m/(TEMP-\d{7}-[0-9a-fA-F]{6})/) {
+
+ my $temporary_cve = $1;
+
+ $self->pointed_hint(
+ 'changelog-references-temp-security-identifier',
+ $latest_pointer, $temporary_cve);
+ }
+
+ # check for bad intended distribution
+ if (
+ $changes =~ m{uploads? \s+ to \s+
+ (?'intended'testing|unstable|experimental|sid)}xi
+ ){
+ my $intended = lc($+{intended});
+
+ $intended = 'unstable'
+ if $intended eq 'sid';
+
+ my $uploaded = $latest_entry->Distribution;
+
+ $self->pointed_hint('bad-intended-distribution', $latest_pointer,
+ "intended for $intended but uploaded to $uploaded")
+ if $uploaded ne $intended
+ && $uploaded ne 'UNRELEASED';
+ }
+
+ if ($changes =~ m{ (Close: \s+ [#] \d+) }xi) {
+
+ my $statement = $1;
+
+ $self->pointed_hint('misspelled-closes-bug', $latest_pointer,
+ $statement);
+ }
+
+ my $changesempty = $changes;
+ $changesempty =~ s/\W//gms;
+
+ $self->pointed_hint('changelog-empty-entry', $latest_pointer)
+ if !length $changesempty
+ && $latest_entry->Distribution ne 'UNRELEASED';
+
+ # before bug 50004 bts removed bug instead of archiving
+ for my $bug (@{$latest_entry->Closes}) {
+
+ $self->pointed_hint('improbable-bug-number-in-closes',
+ $latest_pointer, $bug)
+ if $bug < $FIRST_ARCHIVED_BUG_NUMBER
+ || $bug >= $OUT_OF_REACH_BUG_NUMBER;
+ }
+
+ # Compare against NEWS.Debian if available.
+ for my $field (qw/Distribution Urgency/) {
+
+ $self->pointed_hint(
+ 'changelog-news-debian-mismatch',
+ $news_item->pointer($news->position),
+ $field,
+ $latest_entry->$field,
+ $NOT_EQUALS,
+ $news->$field
+ )
+ if defined $news
+ && length $news->Version
+ && $news->Version eq $latest_entry->Version
+ && $news->$field ne $latest_entry->$field;
+ }
+
+ $self->pointed_hint(
+ 'debian-news-entry-has-unknown-version',
+ $news_item->pointer($news->position),
+ $news->Version
+ )
+ if defined $news
+ && length $news->Version
+ && !exists $allversions{$news->Version};
+
+ # Parse::DebianChangelog adds an additional space to the
+ # beginning of each line, so we have to adjust for that in the
+ # length check.
+ my @lines = split(/\n/, $changes);
+
+ # real start
+ my $position = $real_start;
+ for my $line (@lines) {
+
+ my $pointer = $changelog_item->pointer($position);
+
+ if ($line =~ /^ [*]\s(.{1,5})$/) {
+
+ my $excerpt = $1;
+
+ $self->pointed_hint('debian-changelog-line-too-short',
+ $pointer, $excerpt)
+ unless $1 =~ /:$/;
+ }
+
+ $self->pointed_hint('debian-changelog-line-too-long', $pointer)
+ if length $line >= $MAXIMUM_WIDTH
+ && $line !~ /^ [\s.o*+-]* (?: [Ss]ee:?\s+ )? \S+ $/msx;
+
+ } continue {
+ ++$position;
+ }
+
+ # Strip out all lines that contain the word spelling to avoid false
+ # positives on changelog entries for spelling fixes.
+ $changes =~ s/^.*(?:spelling|typo).*\n//gm;
+
+ check_spelling(
+ $self->data,
+ $changes,
+ $group->spelling_exceptions,
+ $self->spelling_tag_emitter(
+ 'spelling-error-in-changelog', $changelog_item
+ )
+ );
+ }
+
+ return;
+}
+
+# read the changelog itself and check for some issues we cannot find
+# with Parse::DebianChangelog. Also return the "real" line number for
+# the first line of text in the first entry.
+#
+sub check_dch {
+ my ($self) = @_;
+
+ my $unresolved = $self->processable->changelog_item;
+
+ # stop for dangling symbolic link
+ my $item = $unresolved->resolve_path;
+ return 0
+ unless defined $item;
+
+ # return empty changelog
+ return 0
+ unless $item->is_file && $item->is_open_ok;
+
+ # emacs only looks at the last "local variables" in a file, and only at
+ # one within 3000 chars of EOF and on the last page (^L), but that's a bit
+ # pesky to replicate. Demanding a match of $prefix and $suffix ought to
+ # be enough to avoid false positives.
+
+ my $contents;
+ if ($item->basename =~ m{ [.]gz $}x) {
+
+ my $bytes = safe_qx('gunzip', '-c', $item->unpacked_path);
+
+ return 0
+ unless valid_utf8($bytes);
+
+ $contents = decode_utf8($bytes);
+
+ } else {
+
+ # empty unless valis UTF-8
+ $contents = $item->decoded_utf8;
+ }
+
+ my @lines = split(m{\n}, $contents);
+
+ my $prefix;
+ my $suffix;
+ my $real_start = 0;
+
+ my $saw_tab_lead = 0;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ ++$real_start
+ unless $saw_tab_lead;
+
+ $saw_tab_lead = 1
+ if $line =~ /^\s+\S/;
+
+ my $pointer = $item->pointer($position);
+
+ if (
+ $line
+ =~ m{ closes: \s* (( (?:bug)? [#]? \s? \d*) [[:alpha:]] \w*) }ix
+ || $line =~ m{ closes: \s* (?:bug)? [#]? \s? \d+
+ (?: , \s* (?:bug)? [#]? \s? \d+ )*
+ (?: , \s* (( (?:bug)? [#]? \s? \d* ) [[:alpha:]] \w*)) }ix
+ ) {
+
+ my $bug = $1;
+
+ $self->pointed_hint('wrong-bug-number-in-closes', $pointer, $bug)
+ if length $2;
+ }
+
+ if ($line =~ /^(.*)Local\ variables:(.*)$/i) {
+ $prefix = $1;
+ $suffix = $2;
+ }
+
+ # emacs allows whitespace between prefix and variable, hence \s*
+ $self->pointed_hint(
+ 'debian-changelog-file-contains-obsolete-user-emacs-settings',
+ $pointer)
+ if defined $prefix
+ && defined $suffix
+ && $line =~ /^\Q$prefix\E\s*add-log-mailing-address:.*\Q$suffix\E$/;
+
+ } continue {
+ ++$position;
+ }
+
+ return $real_start;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Adopted.pm b/lib/Lintian/Check/Debian/Control/Field/Adopted.pm
new file mode 100644
index 0000000..d9d9379
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Adopted.pm
@@ -0,0 +1,98 @@
+# debian/control/field/adopted -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Adopted;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my $KNOWN_SOURCE_FIELDS= $self->data->load('common/source-fields');
+ my $KNOWN_BINARY_FIELDS= $self->data->load('fields/binary-fields');
+
+ for my $field ($source_fields->names) {
+
+ my ($marker, $bare) = split(qr{-}, $field, 2);
+
+ next
+ unless length $marker
+ && length $bare;
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ # case-insensitive match
+ $self->pointed_hint(
+ 'adopted-extended-field',$pointer,
+ '(in section for source)', $field
+ )
+ if $marker =~ m{^ X }ix
+ && $KNOWN_SOURCE_FIELDS->resembles($bare);
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field ($installable_fields->names) {
+
+ my ($marker, $bare) = split(qr{-}, $field, 2);
+
+ next
+ unless length $marker
+ && length $bare;
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ # case-insensitive match
+ $self->pointed_hint(
+ 'adopted-extended-field', $pointer,
+ "(in section for $installable)", $field
+ )
+ if $marker =~ m{^ X }ix
+ && $KNOWN_BINARY_FIELDS->resembles($bare);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm b/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm
new file mode 100644
index 0000000..dbb5dc2
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm
@@ -0,0 +1,63 @@
+# debian/control/field/architecture/multiline -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Architecture::Multiline;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $field = 'Architecture';
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('multiline-architecture-field',
+ $pointer, $field,"(in section for $installable)")
+ if $installable_fields->value($field)=~ /\n./;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm b/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm
new file mode 100644
index 0000000..50e9663
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm
@@ -0,0 +1,110 @@
+# debian/control/field/build-profiles -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::BuildProfiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my $KNOWN_BUILD_PROFILES= $self->data->load('fields/build-profiles');
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $field = 'Build-Profiles';
+
+ my $raw = $installable_fields->value($field);
+ next
+ unless $raw;
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ if (
+ $raw!~ m{^\s* # skip leading whitespace
+ < # first list start
+ !?[^\s<>]+ # (possibly negated) term
+ (?: # any additional terms
+ \s+ # start with a space
+ !?[^\s<>]+ # (possibly negated) term
+ )* # zero or more additional terms
+ > # first list end
+ (?: # any additional restriction lists
+ \s+ # start with a space
+ < # additional list start
+ !?[^\s<>]+ # (possibly negated) term
+ (?: # any additional terms
+ \s+ # start with a space
+ !?[^\s<>]+ # (possibly negated) term
+ )* # zero or more additional terms
+ > # additional list end
+ )* # zero or more additional lists
+ \s*$ # trailing spaces at the end
+ }x
+ ) {
+ $self->pointed_hint(
+ 'invalid-restriction-formula-in-build-profiles-field',
+ $pointer, $raw,"(in section for $installable)");
+
+ } else {
+ # parse the field and check the profile names
+ $raw =~ s/^\s*<(.*)>\s*$/$1/;
+
+ for my $restrlist (split />\s+</, $raw) {
+ for my $profile (split /\s+/, $restrlist) {
+
+ $profile =~ s/^!//;
+
+ $self->pointed_hint(
+ 'invalid-profile-name-in-build-profiles-field',
+ $pointer, $profile,"(in section for $installable)")
+ unless $KNOWN_BUILD_PROFILES->recognizes($profile)
+ || $profile =~ /^pkg\.[a-z0-9][a-z0-9+.-]+\../;
+ }
+ }
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm b/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm
new file mode 100644
index 0000000..560f89b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm
@@ -0,0 +1,66 @@
+# debian/control/field/built-using -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::BuiltUsing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+ my $installable_fields= $control->installable_fields($installable);
+
+ my $field = 'Built-Using';
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'built-using-field-on-arch-all-package',$pointer,
+ "(in section for $installable)", $field,
+ $installable_fields->value($field)
+ )
+ if $installable_fields->declares($field)
+ && $installable_fields->value('Architecture') eq 'all';
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm b/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm
new file mode 100644
index 0000000..294893b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm
@@ -0,0 +1,114 @@
+# debian/control/field/description/duplicate -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Description::Duplicate;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my %installables_by_synopsis;
+ my %installables_by_exended;
+
+ for my $installable ($control->installables) {
+
+ next
+ if $control->installable_package_type($installable) eq 'udeb';
+
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $description = $installable_fields->untrimmed_value('Description');
+ next
+ unless length $description;
+
+ my ($synopsis, $extended) = split(/\n/, $description, 2);
+
+ $synopsis //= $EMPTY;
+ $extended //= $EMPTY;
+
+ # trim both ends
+ $synopsis =~ s/^\s+|\s+$//g;
+ $extended =~ s/^\s+|\s+$//g;
+
+ if (length $synopsis) {
+ $installables_by_synopsis{$synopsis} //= [];
+ push(@{$installables_by_synopsis{$synopsis}}, $installable);
+ }
+
+ if (length $extended) {
+ $installables_by_exended{$extended} //= [];
+ push(@{$installables_by_exended{$extended}}, $installable);
+ }
+ }
+
+ # check for duplicate short description
+ for my $synopsis (keys %installables_by_synopsis) {
+
+ # Assume that substvars are correctly handled
+ next
+ if $synopsis =~ m/\$\{.+\}/;
+
+ $self->pointed_hint(
+ 'duplicate-short-description',
+ $control->item->pointer,
+ (sort @{$installables_by_synopsis{$synopsis}})
+ )if scalar @{$installables_by_synopsis{$synopsis}} > 1;
+ }
+
+ # check for duplicate long description
+ for my $extended (keys %installables_by_exended) {
+
+ # Assume that substvars are correctly handled
+ next
+ if $extended =~ m/\$\{.+\}/;
+
+ $self->pointed_hint(
+ 'duplicate-long-description',
+ $control->item->pointer,
+ (sort @{$installables_by_exended{$extended}})
+ )if scalar @{$installables_by_exended{$extended}} > 1;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm b/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm
new file mode 100644
index 0000000..1e1e69a
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm
@@ -0,0 +1,83 @@
+# debian/control/field/doubled-up -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::DoubledUp;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ # something like "Maintainer: Maintainer: bad field"
+ my @doubled_up_source_fields
+ = grep { $source_fields->value($_) =~ m{^ \Q$_\E \s* : }ix }
+ $source_fields->names;
+
+ for my $field (@doubled_up_source_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('debian-control-repeats-field-name-in-value',
+ $pointer, '(in section for source)', $field);
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ # something like "Maintainer: Maintainer: bad field"
+ my @doubled_up_installable_fields
+ = grep { $installable_fields->value($_) =~ m{^ \Q$_\E \s* : }ix }
+ $installable_fields->names;
+
+ for my $field (@doubled_up_installable_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('debian-control-repeats-field-name-in-value',
+ $pointer,"(in section for $installable)", $field);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Empty.pm b/lib/Lintian/Check/Debian/Control/Field/Empty.pm
new file mode 100644
index 0000000..15b48ca
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Empty.pm
@@ -0,0 +1,84 @@
+# debian/control/field/empty -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Empty;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my @empty_source_fields
+ = grep { !length $source_fields->value($_) } $source_fields->names;
+
+ for my $field (@empty_source_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'debian-control-has-empty-field', $pointer,
+ '(in source paragraph)', $field
+ );
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my @empty_installable_fields
+ = grep { !length $installable_fields->value($_) }
+ $installable_fields->names;
+
+ for my $field (@empty_installable_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'debian-control-has-empty-field',$pointer,
+ "(in section for $installable)", $field
+ );
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm b/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm
new file mode 100644
index 0000000..743be38
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Misplaced.pm
@@ -0,0 +1,67 @@
+# debian/control/field/misplaced -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Misplaced;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my @build_fields
+ =qw{Build-Depends Build-Depends-Indep Build-Conflicts Build-Conflicts-Indep};
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (@build_fields) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('build-prerequisite-in-installable-section',
+ $pointer, $field,"(in section for $installable)")
+ if $installable_fields->declares($field);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Redundant.pm b/lib/Lintian/Check/Debian/Control/Field/Redundant.pm
new file mode 100644
index 0000000..9f78dd4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Redundant.pm
@@ -0,0 +1,68 @@
+# debian/control/field/redundant -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Redundant;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field ($installable_fields->names) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'installable-field-mirrors-source',$pointer,
+ "(in section for $installable)", $field
+ )
+ if $source_fields->declares($field)
+ && $installable_fields->value($field) eq
+ $source_fields->value($field);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Relation.pm b/lib/Lintian/Check/Debian/Control/Field/Relation.pm
new file mode 100644
index 0000000..3047971
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Relation.pm
@@ -0,0 +1,180 @@
+# debian/control/field/relation -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Relation;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ # Check that fields which should be comma-separated or
+ # pipe-separated have separators. Places where this tends to
+ # cause problems are with wrapped lines such as:
+ #
+ # Depends: foo, bar
+ # baz
+ #
+ # or with substvars. If two substvars aren't separated by a
+ # comma, but at least one of them expands to an empty string,
+ # there will be a lurking bug. The result will be syntactically
+ # correct, but as soon as both expand into something non-empty,
+ # there will be a syntax error.
+ #
+ # The architecture list can contain things that look like packages
+ # separated by spaces, so we have to remove any architecture
+ # restrictions first. This unfortunately distorts our report a
+ # little, but hopefully not too much.
+ #
+ # Also check for < and > relations. dpkg-gencontrol warns about
+ # them and then transforms them in the output to <= and >=, but
+ # it's easy to miss the error message. Similarly, check for
+ # duplicates, which dpkg-source eliminates.
+
+ for my $field (
+ qw(Build-Depends Build-Depends-Indep
+ Build-Conflicts Build-Conflicts-Indep)
+ ) {
+ next
+ unless $source_fields->declares($field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ my @values = $source_fields->trimmed_list($field, qr{ \s* , \s* }x);
+ my @obsolete = grep { m{ [(] [<>] \s* [^<>=]+ [)] }x } @values;
+
+ $self->pointed_hint(
+ 'obsolete-relation-form-in-source',
+ $pointer, '(in source paragraph)',
+ $field, $_
+ )for @obsolete;
+
+ my $raw = $source_fields->value($field);
+ my $relation = Lintian::Relation->new->load($raw);
+
+ for my $redundant_set ($relation->redundancies) {
+
+ $self->pointed_hint('redundant-control-relation', $pointer,
+ '(in source paragraph)',
+ $field,join(', ', sort @{$redundant_set}));
+ }
+
+ $self->check_separators($raw, $pointer, '(in source paragraph)');
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (
+ qw(Pre-Depends Depends Recommends Suggests Breaks
+ Conflicts Provides Replaces Enhances)
+ ) {
+ next
+ unless $installable_fields->declares($field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ my @values
+ = $installable_fields->trimmed_list($field, qr{ \s* , \s* }x);
+ my @obsolete = grep { m{ [(] [<>] \s* [^<>=]+ [)] }x } @values;
+
+ $self->pointed_hint(
+ 'obsolete-relation-form-in-source',
+ $pointer, "(in section for $installable)",
+ $field, $_
+ )for @obsolete;
+
+ my $relation
+ = $self->processable->binary_relation($installable, $field);
+
+ for my $redundant_set ($relation->redundancies) {
+
+ $self->pointed_hint(
+ 'redundant-control-relation', $pointer,
+ "(in section for $installable)", $field,
+ join(', ', sort @{$redundant_set})
+ );
+ }
+
+ my $raw = $installable_fields->value($field);
+ $self->check_separators($raw, $pointer,
+ "(in section for $installable)");
+ }
+ }
+
+ return;
+}
+
+sub check_separators {
+ my ($self, $string, $pointer, $explainer) = @_;
+
+ $string =~ s/\n(\s)/$1/g;
+ $string =~ s/\[[^\]]*\]//g;
+
+ if (
+ $string =~ m{(?:^|\s)
+ (
+ (?:\w[^\s,|\$\(]+|\$\{\S+:Depends\})\s*
+ (?:\([^\)]*\)\s*)?
+ )
+ \s+
+ (
+ (?:\w[^\s,|\$\(]+|\$\{\S+:Depends\})\s*
+ (?:\([^\)]*\)\s*)?
+ )}x
+ ) {
+ my ($prev, $next) = ($1, $2);
+
+ # trim right
+ $prev =~ s/\s+$//;
+ $next =~ s/\s+$//;
+
+ $self->pointed_hint('missing-separator-between-items',
+ $pointer,$explainer, "'$prev' and '$next'");
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm b/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm
new file mode 100644
index 0000000..b97a673
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm
@@ -0,0 +1,99 @@
+# debian/control/field/rules-requires-root -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::RulesRequiresRoot;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(first_value);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ my @r3_misspelled = grep { $_ ne 'Rules-Requires-Root' }
+ grep { m{^ Rules? - Requires? - Roots? $}xi } $source_fields->names;
+
+ for my $field (@r3_misspelled) {
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('spelling-error-in-rules-requires-root',
+ $pointer, $field);
+ }
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $source_fields->position('Rules-Requires-Root');
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('rules-do-not-require-root', $pointer)
+ if $source_fields->value('Rules-Requires-Root') eq 'no';
+
+ $self->pointed_hint('rules-require-root-explicitly', $pointer)
+ if $source_fields->declares('Rules-Requires-Root')
+ && $source_fields->value('Rules-Requires-Root') ne 'no';
+
+ $self->pointed_hint('silent-on-rules-requiring-root', $pointer)
+ unless $source_fields->declares('Rules-Requires-Root');
+
+ if ( !$source_fields->declares('Rules-Requires-Root')
+ || $source_fields->value('Rules-Requires-Root') eq 'no') {
+
+ for my $installable ($self->group->get_installables) {
+
+ my $user_owned_item
+ = first_value { $_->owner ne 'root' || $_->group ne 'root' }
+ @{$installable->installed->sorted_list};
+
+ next
+ unless defined $user_owned_item;
+
+ my $owner = $user_owned_item->owner;
+ my $group = $user_owned_item->group;
+
+ $self->pointed_hint('rules-silently-require-root',
+ $pointer, $installable->name,
+ "($owner:$group)", $user_owned_item->name);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Section.pm b/lib/Lintian/Check/Debian/Control/Field/Section.pm
new file mode 100644
index 0000000..dd0ba52
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Section.pm
@@ -0,0 +1,52 @@
+# debian/control/field/section -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Section;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ $self->pointed_hint('no-source-section', $control->item->pointer)
+ unless $source_fields->declares('Section');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Field/Spacing.pm b/lib/Lintian/Check/Debian/Control/Field/Spacing.pm
new file mode 100644
index 0000000..070ebdf
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Field/Spacing.pm
@@ -0,0 +1,78 @@
+# debian/control/field/spacing -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Field::Spacing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $item = $self->processable->debian_control->item;
+ return
+ unless defined $item;
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ my $position = 1;
+ while (defined(my $line = shift @lines)) {
+
+ # strip leading spaces
+ $line =~ s{\s*$}{};
+
+ next
+ if $line =~ m{^ [#]}x;
+
+ # line with field:
+ if ($line =~ m{^ (\S+) : }x) {
+
+ my $field = $1;
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('debian-control-has-unusual-field-spacing',
+ $pointer, $field)
+ unless $line =~ m{^ \S+ : [ ] \S }x
+ || $line =~ m{^ \S+ : $}x;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Link.pm b/lib/Lintian/Check/Debian/Control/Link.pm
new file mode 100644
index 0000000..5f3f751
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Link.pm
@@ -0,0 +1,57 @@
+# debian/control/link -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Link;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless $debian_dir;
+
+ my $item = $debian_dir->child('control');
+ return
+ unless $item;
+
+ $self->pointed_hint('debian-control-file-is-a-symlink', $item->pointer)
+ if $item->is_symlink;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm
new file mode 100644
index 0000000..7cd78e5
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm
@@ -0,0 +1,74 @@
+# debian/control/prerequisite/circular -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Prerequisite::Circular;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my @prerequisite_fields = qw(Pre-Depends Depends Recommends Suggests);
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (@prerequisite_fields) {
+
+ next
+ unless $control->installable_fields($installable)
+ ->declares($field);
+
+ my $relation
+ = $self->processable->binary_relation($installable, $field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'circular-installation-prerequisite',
+ $pointer, "(in section for $installable)",
+ $field,$relation->to_string
+ )if $relation->satisfies($installable);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm
new file mode 100644
index 0000000..948076f
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm
@@ -0,0 +1,145 @@
+# debian/control/prerequisite/development -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Prerequisite::Development;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ next
+ unless $installable =~ /-dev$/;
+
+ my $field = 'Depends';
+
+ next
+ unless $installable_fields->declares($field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ my @depends
+ = $installable_fields->trimmed_list($field, qr{ \s* , \s* }x);
+
+ for my $other_name ($control->installables) {
+
+ next
+ if $other_name =~ /-(?:dev|docs?|common)$/;
+
+ next
+ unless $other_name =~ /^lib[\w.+-]+\d/;
+
+ my @relevant
+ = grep { m{ (?: ^ | [\s|] ) \Q$other_name\E (?: [\s|(] | \z ) }x }
+ @depends;
+
+ # If there are any alternatives here, something special is
+ # going on. Assume that the maintainer knows what they're
+ # doing. Otherwise, separate out just the versions.
+ next
+ if any { m{ [|] }x } @relevant;
+
+ my @unsorted;
+ for my $package (@relevant) {
+
+ $package =~ m{^ [\w.+-]+ \s* [(] ([^)]+) [)] }x;
+ push(@unsorted, ($1 // $EMPTY));
+ }
+
+ my @versions = sort @unsorted;
+
+ my $context;
+
+ # If there's only one mention of this package, the dependency
+ # should be tight. Otherwise, there should be both >>/>= and
+ # <</<= dependencies that mention the source, binary, or
+ # upstream version. If there are more than three mentions of
+ # the package, again something is weird going on, so we assume
+ # they know what they're doing.
+ if (@relevant == 1) {
+ unless ($versions[0]
+ =~ /^\s*=\s*\$\{(?:binary:Version|Source-Version)\}/) {
+ # Allow "pkg (= ${source:Version})" if (but only if)
+ # the target is an arch:all package. This happens
+ # with a lot of mono-packages.
+ #
+ # Note, we do not check if the -dev package is
+ # arch:all as well. The version-substvars check
+ # handles that for us.
+ next
+ if $control->installable_fields($other_name)
+ ->value('Architecture') eq 'all'
+ && $versions[0]
+ =~ m{^ \s* = \s* \$[{]source:Version[}] }x;
+
+ $context = $relevant[0];
+ }
+
+ } elsif (@relevant == 2) {
+ unless (
+ $versions[0] =~ m{^ \s* <[=<] \s* \$[{]
+ (?: (?:binary|source):(?:Upstream-)?Version
+ | Source-Version) [}] }xsm
+ && $versions[1] =~ m{^ \s* >[=>] \s* \$[{]
+ (?: (?:binary|source):(?:Upstream-)?Version
+ | Source-Version) [}] }xsm
+ ) {
+ $context = "$relevant[0], $relevant[1]";
+ }
+ }
+
+ $self->pointed_hint('weak-library-dev-dependency',
+ $pointer, "(in section for $installable)",
+ $field, $context)
+ if length $context;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm b/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm
new file mode 100644
index 0000000..08ea510
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm
@@ -0,0 +1,99 @@
+# debian/control/prerequisitie/redundant -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Control::Prerequisite::Redundant;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $ARROW => q{->};
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ # Make sure that a stronger dependency field doesn't satisfy any of
+ # the elements of a weaker dependency field. dpkg-gencontrol will
+ # fix this up for us, but we want to check the source package
+ # since dpkg-gencontrol may silently "fix" something that's a more
+ # subtle bug.
+
+ # ordered from stronger to weaker
+ my @ordered_fields = qw(Pre-Depends Depends Recommends Suggests);
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my @remaining_fields = @ordered_fields;
+
+ for my $stronger (@ordered_fields) {
+
+ shift @remaining_fields;
+
+ next
+ unless $control->installable_fields($installable)
+ ->declares($stronger);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($stronger);
+ my $pointer = $control_item->pointer($position);
+
+ my $relation
+ = $self->processable->binary_relation($installable,$stronger);
+
+ for my $weaker (@remaining_fields) {
+
+ my @prerequisites = $control->installable_fields($installable)
+ ->trimmed_list($weaker, qr{\s*,\s*});
+
+ for my $prerequisite (@prerequisites) {
+
+ $self->pointed_hint(
+ 'redundant-installation-prerequisite',$pointer,
+ "(in section for $installable)",$weaker,
+ $ARROW, $stronger,
+ $prerequisite
+ )if $relation->satisfies($prerequisite);
+ }
+ }
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Copyright.pm b/lib/Lintian/Check/Debian/Copyright.pm
new file mode 100644
index 0000000..6eb8900
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright.pm
@@ -0,0 +1,586 @@
+# copyright -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2011 Jakub Wilk
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Copyright;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any all none uniq);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Deb822;
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+const my $APPROXIMATE_GPL_LENGTH => 12_000;
+const my $APPROXIMATE_GFDL_LENGTH => 12_000;
+const my $APPROXIMATE_APACHE_2_LENGTH => 10_000;
+
+sub spelling_tag_emitter {
+ my ($self, @orig_args) = @_;
+
+ return sub {
+ return $self->hint(@orig_args, @_);
+ };
+}
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined } map { $debian_dir->child($_) } @candidates;
+
+ # look for <pkgname>.copyright for a single installable
+ if (@files == 1) {
+ my $single = $files[0];
+
+ $self->pointed_hint('named-copyright-for-single-installable',
+ $single->pointer)
+ unless $single->name eq 'debian/copyright';
+ }
+
+ $self->hint('no-debian-copyright-in-source')
+ unless @files;
+
+ my @symlinks = grep { $_->is_symlink } @files;
+ $self->pointed_hint('debian-copyright-is-symlink', $_->pointer)
+ for @symlinks;
+
+ return;
+}
+
+# no copyright in udebs
+sub binary {
+ my ($self) = @_;
+
+ my $package = $self->processable->name;
+
+ # looking up entry without slash first; index should not be so picky
+ my $doclink
+ = $self->processable->installed->lookup("usr/share/doc/$package");
+ if ($doclink && $doclink->is_symlink) {
+
+ # check if this symlink references a directory elsewhere
+ if ($doclink->link =~ m{^(?:\.\.)?/}s) {
+ $self->pointed_hint(
+ 'usr-share-doc-symlink-points-outside-of-usr-share-doc',
+ $doclink->pointer, $doclink->link);
+ return;
+ }
+
+ # The symlink may point to a subdirectory of another
+ # /usr/share/doc directory. This is allowed if this
+ # package depends on link and both packages come from the
+ # same source package.
+ #
+ # Policy requires that packages be built from the same
+ # source if they're going to do this, which by my (rra's)
+ # reading means that we should have a strict version
+ # dependency. However, in practice the copyright file
+ # doesn't change a lot and strict version dependencies
+ # cause other problems (such as with arch: any / arch: all
+ # package combinations and binNMUs).
+ #
+ # We therefore just require the dependency for now and
+ # don't worry about the version number.
+ my $link = $doclink->link;
+ $link =~ s{/.*}{};
+
+ unless ($self->depends_on($self->processable, $link)) {
+ $self->hint('usr-share-doc-symlink-without-dependency', $link);
+
+ return;
+ }
+
+ # Check if the link points to a package from the same source.
+ $self->check_cross_link($link);
+
+ return;
+ }
+
+ # now with a slash; indicates directory
+ my $docdir
+ = $self->processable->installed->lookup("usr/share/doc/$package/");
+ unless ($docdir) {
+ $self->hint('no-copyright-file');
+ return;
+ }
+
+ my $found = 0;
+ my $zipped = $docdir->child('copyright.gz');
+ if (defined $zipped) {
+
+ $self->pointed_hint('copyright-file-compressed', $zipped->pointer);
+ $found = 1;
+ }
+
+ my $linked = 0;
+
+ my $item = $docdir->child('copyright');
+ if (defined $item) {
+ $found = 1;
+
+ if ($item->is_symlink) {
+
+ $self->pointed_hint('copyright-file-is-symlink', $item->pointer);
+ $linked = 1;
+ # fall through; coll/copyright-file prevents reading through evil link
+ }
+ }
+
+ unless ($found) {
+
+ # #522827: special exception for perl for now
+ $self->hint('no-copyright-file')
+ unless $package eq 'perl';
+
+ return;
+ }
+
+ my $copyrigh_path;
+
+ my $uncompressed
+ = $self->processable->installed->resolve_path(
+ "usr/share/doc/$package/copyright");
+ $copyrigh_path = $uncompressed->unpacked_path
+ if defined $uncompressed;
+
+ my $compressed
+ = $self->processable->installed->resolve_path(
+ "usr/share/doc/$package/copyright.gz");
+ if (defined $compressed) {
+
+ my $bytes = safe_qx('gunzip', '-c', $compressed->unpacked_path);
+ my $contents = decode_utf8($bytes);
+
+ my $extracted
+ = path($self->processable->basedir)->child('copyright')->stringify;
+ path($extracted)->spew($contents);
+
+ $copyrigh_path = $extracted;
+ }
+
+ return
+ unless length $copyrigh_path;
+
+ my $bytes = path($copyrigh_path)->slurp;
+
+ # another check complains about invalid encoding
+ return
+ unless valid_utf8($bytes);
+
+ # check contents of copyright file
+ my $contents = decode_utf8($bytes);
+
+ $self->hint('copyright-has-crs')
+ if $contents =~ /\r/;
+
+ my $wrong_directory_detected = 0;
+
+ my $KNOWN_COMMON_LICENSES
+ = $self->data->load('copyright-file/common-licenses');
+
+ if ($contents =~ m{ (usr/share/common-licenses/ ( [^ \t]*? ) \.gz) }xsm) {
+ my ($path, $license) = ($1, $2);
+ if ($KNOWN_COMMON_LICENSES->recognizes($license)) {
+ $self->hint('copyright-refers-to-compressed-license', $path);
+ }
+ }
+
+ # Avoid complaining about referring to a versionless license file
+ # if the word "version" appears nowhere in the copyright file.
+ # This won't catch all of our false positives for GPL references
+ # that don't include a specific version number, but it will get
+ # the obvious ones.
+ if ($contents =~ m{(usr/share/common-licenses/(L?GPL|GFDL))([^-])}i) {
+ my ($ref, $license, $separator) = ($1, $2, $3);
+ if ($separator =~ /[\d\w]/) {
+ $self->hint('copyright-refers-to-nonexistent-license-file',
+ "$ref$separator");
+ } elsif ($contents =~ /\b(?:any|or)\s+later(?:\s+version)?\b/i
+ || $contents =~ /License: $license-[\d\.]+\+/i
+ || $contents =~ /as Perl itself/i
+ || $contents =~ /License-Alias:\s+Perl/
+ || $contents =~ /License:\s+Perl/) {
+ $self->hint('copyright-refers-to-symlink-license', $ref);
+ } else {
+ $self->hint('copyright-refers-to-versionless-license-file', $ref)
+ if $contents =~ /\bversion\b/;
+ }
+ }
+
+ # References to /usr/share/common-licenses/BSD are deprecated as of Policy
+ # 3.8.5.
+ if ($contents =~ m{/usr/share/common-licenses/BSD}) {
+ $self->hint('copyright-refers-to-deprecated-bsd-license-file');
+ }
+
+ if ($contents =~ m{(usr/share/common-licences)}) {
+ $self->hint('copyright-refers-to-incorrect-directory', $1);
+ $wrong_directory_detected = 1;
+ }
+
+ if ($contents =~ m{usr/share/doc/copyright}) {
+ $self->hint('copyright-refers-to-old-directory');
+ $wrong_directory_detected = 1;
+ }
+
+ if ($contents =~ m{usr/doc/copyright}) {
+ $self->hint('copyright-refers-to-old-directory');
+ $wrong_directory_detected = 1;
+ }
+
+ # Lame check for old FSF zip code. Try to avoid false positives from other
+ # Cambridge, MA addresses.
+ if ($contents =~ m/(?:Free\s*Software\s*Foundation.*02139|02111-1307)/s) {
+ $self->hint('old-fsf-address-in-copyright-file');
+ }
+
+ # Whether the package is covered by the GPL, used later for the
+ # libssl check.
+ my $gpl;
+
+ if (
+ length $contents > $APPROXIMATE_GPL_LENGTH
+ && (
+ $contents =~ m{ \b \QGNU GENERAL PUBLIC LICENSE\E \s*
+ \QTERMS AND CONDITIONS FOR COPYING,\E \s*
+ \QDISTRIBUTION AND MODIFICATION\E \b }msx
+ || (
+ $contents =~ m{ \b \QGNU GENERAL PUBLIC LICENSE\E
+ \s* \QVersion 3\E }msx
+ && $contents =~ m{ \b \QTERMS AND CONDITIONS\E \s }msx
+ )
+ )
+ ) {
+ $self->hint('copyright-file-contains-full-gpl-license');
+ $gpl = 1;
+ }
+
+ if (
+ length $contents > $APPROXIMATE_GFDL_LENGTH
+ && $contents =~ m{ \b \QGNU Free Documentation License\E
+ \s* \QVersion 1.2\E }msx
+ && $contents =~ m{ \b \Q1. APPLICABILITY AND DEFINITIONS\E }msx
+ ) {
+
+ $self->hint('copyright-file-contains-full-gfdl-license');
+ }
+
+ if ( length $contents > $APPROXIMATE_APACHE_2_LENGTH
+ && $contents =~ m{ \b \QApache License\E \s+ \QVersion 2.0,\E }msx
+ && $contents
+ =~ m{ \QTERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION\E }msx
+ ) {
+
+ $self->hint('copyright-file-contains-full-apache-2-license');
+ }
+
+ # wtf?
+ if ( ($contents =~ m{common-licenses(/\S+)})
+ && ($contents !~ m{/usr/share/common-licenses/})) {
+ $self->hint('copyright-does-not-refer-to-common-license-file', $1);
+ }
+
+ # This check is a bit prone to false positives, since some other
+ # licenses mention the GPL. Also exclude any mention of the GPL
+ # following what looks like mail header fields, since sometimes
+ # e-mail discussions of licensing are included in the copyright
+ # file but aren't referring to the license of the package.
+ unless (
+ $contents =~ m{/usr/share/common-licenses}
+ || $contents =~ m/Zope Public License/
+ || $contents =~ m/LICENSE AGREEMENT FOR PYTHON 1.6.1/
+ || $contents =~ m/LaTeX Project Public License/
+ || $contents
+ =~ m/(?:^From:.*^To:|^To:.*^From:).*(?:GNU General Public License|GPL)/ms
+ || $contents =~ m/AFFERO GENERAL PUBLIC LICENSE/
+ || $contents =~ m/GNU Free Documentation License[,\s]*Version 1\.1/
+ || $contents =~ m/CeCILL FREE SOFTWARE LICENSE AGREEMENT/ #v2.0
+ || $contents =~ m/FREE SOFTWARE LICENSING AGREEMENT CeCILL/ #v1.1
+ || $contents =~ m/CNRI OPEN SOURCE GPL-COMPATIBLE LICENSE AGREEMENT/
+ || $contents =~ m/compatible\s+with\s+(?:the\s+)?(?:GNU\s+)?GPL/
+ || $contents =~ m/(?:GNU\s+)?GPL\W+compatible/
+ || $contents
+ =~ m/was\s+previously\s+(?:distributed\s+)?under\s+the\s+GNU/
+ || $contents
+ =~ m/means\s+either\s+the\s+GNU\s+General\s+Public\s+License/
+ || $wrong_directory_detected
+ ) {
+ if (
+ check_names_texts(
+ $contents,
+ qr/\b(?:GFDL|gnu[-_]free[-_]documentation[-_]license)\b/i,
+ qr/GNU Free Documentation License|(?-i:\bGFDL\b)/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-gfdl');
+ }elsif (
+ check_names_texts(
+ $contents,
+qr/\b(?:LGPL|gnu[-_](?:lesser|library)[-_]general[-_]public[-_]license)\b/i,
+qr/GNU (?:Lesser|Library) General Public License|(?-i:\bLGPL\b)/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-lgpl');
+ }elsif (
+ check_names_texts(
+ $contents,
+ qr/\b(?:GPL|gnu[-_]general[-_]public[-_]license)\b/i,
+ qr/GNU General Public License|(?-i:\bGPL\b)/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-gpl');
+ $gpl = 1;
+ }elsif (
+ check_names_texts(
+ $contents,qr/\bapache[-_]2/i,
+ qr/\bApache License\s*,?\s*Version 2|\b(?-i:Apache)-2/i
+ )
+ ) {
+ $self->hint('copyright-not-using-common-license-for-apache2');
+ }
+ }
+
+ if (
+ check_names_texts(
+ $contents,
+ qr/\b(?:perl|artistic)\b/,
+ sub {
+ my ($text) = @_;
+ $text
+ =~ /(?:under )?(?:the )?(?:same )?(?:terms )?as Perl itself\b/i
+ && $text !~ m{usr/share/common-licenses/};
+ }
+ )
+ ) {
+ $self->hint('copyright-file-lacks-pointer-to-perl-license');
+ }
+
+ # Checks for various packaging helper boilerplate.
+
+ $self->hint('helper-templates-in-copyright')
+ if $contents =~ m{<fill in (?:http/)?ftp site>}
+ || $contents =~ /<Must follow here>/
+ || $contents =~ /<Put the license of the package here/
+ || $contents =~ /<put author[\'\(]s\)? name and email here>/
+ || $contents =~ /<Copyright \(C\) YYYY Name OfAuthor>/
+ || $contents =~ /Upstream Author\(s\)/
+ || $contents =~ /<years>/
+ || $contents =~ /<special license>/
+ || $contents
+ =~ /<Put the license of the package here indented by 1 space>/
+ || $contents
+ =~ /<This follows the format of Description: lines\s*in control file>/
+ || $contents =~ /<Including paragraphs>/
+ || $contents =~ /<likewise for another author>/;
+
+ # dh-make-perl
+ $self->hint('copyright-contains-automatically-extracted-boilerplate')
+ if $contents =~ /This copyright info was automatically extracted/;
+
+ $self->hint('helper-templates-in-copyright')
+ if $contents =~ /<INSERT COPYRIGHT YEAR\(S\) HERE>/;
+
+ $self->hint('copyright-has-url-from-dh_make-boilerplate')
+ if $contents =~ m{url://};
+
+ # dh-make boilerplate
+ my @dh_make_boilerplate = (
+"# Please also look if there are files or directories which have a\n# different copyright/license attached and list them here.",
+"# If you want to use GPL v2 or later for the /debian/* files use\n# the following clauses, or change it to suit. Delete these two lines"
+ );
+
+ $self->hint('copyright-contains-dh_make-todo-boilerplate')
+ if any { $contents =~ /$_/ } @dh_make_boilerplate;
+
+ $self->hint('copyright-with-old-dh-make-debian-copyright')
+ if $contents =~ /The\s+Debian\s+packaging\s+is\s+\(C\)\s+\d+/i;
+
+ # Other flaws in the copyright phrasing or contents.
+ if ($found && !$linked) {
+ $self->hint('copyright-without-copyright-notice')
+ unless $contents
+ =~ m{(?:Copyright|Copr\.|\N{COPYRIGHT SIGN})(?:.*|[\(C\):\s]+)\b\d{4}\b
+ |\bpublic(?:\s+|-)domain\b}xi;
+ }
+
+ check_spelling(
+ $self->data,$contents,
+ $self->group->spelling_exceptions,
+ $self->spelling_tag_emitter('spelling-error-in-copyright'), 0
+ );
+
+ # Now, check for linking against libssl if the package is covered
+ # by the GPL. (This check was requested by ftp-master.) First,
+ # see if the package is under the GPL alone and try to exclude
+ # packages with a mix of GPL and LGPL or Artistic licensing or
+ # with an exception or exemption.
+ if (($gpl || $contents =~ m{/usr/share/common-licenses/GPL})
+ &&$contents
+ !~ m{exception|exemption|/usr/share/common-licenses/(?!GPL)\S}){
+
+ my @depends
+ = split(/\s*,\s*/,$self->processable->fields->value('Depends'));
+ my @predepends
+ = split(/\s*,\s*/,$self->processable->fields->value('Pre-Depends'));
+
+ $self->hint('possible-gpl-code-linked-with-openssl')
+ if any { /^libssl[0-9.]+(?:\s|\z)/ && !/\|/ }(@depends, @predepends);
+ }
+
+ return;
+} # </run>
+
+# -----------------------------------
+
+# Returns true if the package whose information is in $processable depends $package
+# or if $package is essential.
+sub depends_on {
+ my ($self, $processable, $package) = @_;
+
+ my $KNOWN_ESSENTIAL = $self->data->load('fields/essential');
+
+ return 1
+ if $KNOWN_ESSENTIAL->recognizes($package);
+
+ my $strong = $processable->relation('strong');
+ return 1
+ if $strong->satisfies($package);
+
+ my $arch = $processable->architecture;
+ return 1
+ if $arch ne 'all' and $strong->satisfies("${package}:${arch}");
+
+ return 0;
+}
+
+# Checks cross pkg links for /usr/share/doc/$pkg links
+sub check_cross_link {
+ my ($self, $foreign) = @_;
+
+ my $source = $self->group->source;
+ if ($source) {
+
+ # source package is available; check its list of binaries
+ return
+ if any { $foreign eq $_ } $source->debian_control->installables;
+
+ $self->hint('usr-share-doc-symlink-to-foreign-package', $foreign);
+
+ } else {
+ # The source package is not available, but the binary could
+ # be present anyway; If they are in the same group, they claim
+ # to have the same source (and source version)
+ return
+ if any { $_->name eq $foreign }$self->group->get_installables;
+
+ # It was not, but since the source package was not present, we cannot
+ # tell if it is foreign or not at this point.
+
+ $self->hint(
+'cannot-check-whether-usr-share-doc-symlink-points-to-foreign-package'
+ );
+ }
+
+ return;
+}
+
+# Checks the name and text of every license in the file against given name and
+# text check coderefs, if the file is in the new format, if the file is in the
+# old format only runs the text coderef against the whole file.
+sub check_names_texts {
+ my ($contents, $name_check, $action) = @_;
+
+ my $text_check;
+
+ if ((ref($action) || $EMPTY) eq 'Regexp') {
+ $text_check = sub {
+ my ($textref) = @_;
+ return ${$textref} =~ $action;
+ };
+
+ } else {
+ $text_check = sub {
+ my ($textref) = @_;
+ return $action->(${$textref});
+ };
+ }
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @paragraphs;
+ try {
+ @paragraphs = $deb822->parse_string($contents);
+
+ } catch {
+ # parse error: copyright not in new format, just check text
+ return $text_check->(\$contents);
+ }
+
+ my @licenses = grep { length } map { $_->value('License') } @paragraphs;
+ for my $license (@licenses) {
+
+ my ($name, $text) = ($license =~ /^\s*([^\r\n]+)\r?\n(.*)\z/s);
+
+ next
+ unless length $text;
+
+ next
+ if $text =~ /^[\s\r\n]*\z/;
+
+ return 1
+ if $name =~ $name_check
+ && $text_check->(\$text);
+ }
+
+ # did not match anything
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm b/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm
new file mode 100644
index 0000000..72e91b4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm
@@ -0,0 +1,105 @@
+# debian/copyright/apache-notice -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2011 Jakub Wilk
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Copyright::ApacheNotice;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined } map { $debian_dir->child($_) } @candidates;
+
+ # another check complains about legacy encoding, if needed
+ my @valid_utf8 = grep { $_->is_valid_utf8 } @files;
+
+ $self->check_apache_notice_files($_)for @valid_utf8;
+
+ return;
+}
+
+sub check_apache_notice_files {
+ my ($self, $file) = @_;
+
+ my $contents = $file->decoded_utf8;
+ return
+ unless $contents =~ /apache[-\s]+2\./i;
+
+ my @notice_files = grep {
+ $_->basename =~ /^NOTICE(\.txt)?$/
+ and $_->is_open_ok
+ and $_->bytes =~ /apache/i
+ } @{$self->processable->patched->sorted_list};
+ return
+ unless @notice_files;
+
+ my @binaries = grep { $_->type ne 'udeb' } $self->group->get_installables;
+ return
+ unless @binaries;
+
+ for my $binary (@binaries) {
+
+ # look at all path names in the package
+ my @names = map { $_->name } @{$binary->installed->sorted_list};
+
+ # and also those shipped in jars
+ my @jars = grep { scalar keys %{$_->java_info} }
+ @{$binary->installed->sorted_list};
+ push(@names, keys %{$_->java_info->{files}})for @jars;
+
+ return
+ if any { m{/NOTICE(\.txt)?(\.gz)?$} } @names;
+ }
+
+ $self->pointed_hint('missing-notice-file-for-apache-license', $_->pointer)
+ for @notice_files;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Copyright/Dep5.pm b/lib/Lintian/Check/Debian/Copyright/Dep5.pm
new file mode 100644
index 0000000..1084de8
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright/Dep5.pm
@@ -0,0 +1,968 @@
+# debian/copyright/dep5 -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2011 Jakub Wilk
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Copyright::Dep5;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any all none uniq);
+use Syntax::Keyword::Try;
+use Regexp::Wildcards;
+use Time::Piece;
+use XML::LibXML;
+
+use Lintian::Deb822;
+use Lintian::Relation::Version qw(versions_compare);
+use Lintian::Util qw(match_glob);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $LAST_SIGNIFICANT_DEP5_CHANGE => '0+svn~166';
+const my $LAST_DEP5_OVERHAUL => '0+svn~148';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $HYPHEN => q{-};
+const my $ASTERISK => q{*};
+
+const my $MINIMUM_CREATIVE_COMMMONS_LENGTH => 20;
+const my $LAST_ITEM => -1;
+
+const my %NEW_FIELD_NAMES => (
+ 'Format-Specification' => 'Format',
+ 'Maintainer' => 'Upstream-Contact',
+ 'Upstream-Maintainer' => 'Upstream-Contact',
+ 'Contact' => 'Upstream-Contact',
+ 'Name' => 'Upstream-Name',
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined $_ && !$_->is_symlink }
+ map { $debian_dir->child($_) } @candidates;
+
+ # another check complains about legacy encoding, if needed
+ my @valid_utf8 = grep { $_->is_valid_utf8 } @files;
+
+ $self->check_dep5_copyright($_) for @valid_utf8;
+
+ return;
+}
+
+# The policy states, since 4.0.0, that people should use "https://" for the
+# format URI. This is checked later in check_dep5_copyright.
+# return undef is not dep5 and '' if unknown version
+sub find_dep5_version {
+ my ($self, $file, $original_uri) = @_;
+
+ my $uri = $original_uri;
+ my $version;
+
+ if ($uri =~ /\b(?:rev=REVISION|VERSIONED_FORMAT_URL)\b/) {
+
+ $self->pointed_hint('boilerplate-copyright-format-uri',
+ $file->pointer,$uri);
+ return undef;
+ }
+
+ if (
+ $uri =~ s{ https?://wiki\.debian\.org/
+ Proposals/CopyrightFormat\b}{}xsm
+ ){
+ $version = '0~wiki';
+
+ $version = "$version~$1"
+ if $uri =~ /^\?action=recall&rev=(\d+)$/;
+
+ return $version;
+ }
+
+ if ($uri =~ m{^https?://dep(-team\.pages)?\.debian\.net/deps/dep5/?$}) {
+
+ $version = '0+svn';
+ return $version;
+ }
+
+ if (
+ $uri =~ s{\A https?://svn\.debian\.org/
+ wsvn/dep/web/deps/dep5\.mdwn\b}{}xsm
+ ){
+ $version = '0+svn';
+
+ $version = "$version~$1"
+ if $uri =~ /^\?(?:\S+[&;])?rev=(\d+)(?:[&;]\S+)?$/;
+
+ return $version;
+ }
+ if (
+ $uri =~ s{ \A https?://(?:svn|anonscm)\.debian\.org/
+ viewvc/dep/web/deps/dep5\.mdwn\b}{}xsm
+ ){
+ $version = '0+svn';
+ $uri =~ m{\A \? (?:\S+[&;])?
+ (?:pathrev|revision|rev)=(\d+)(?:[&;]\S+)?
+ \Z}xsm
+ and $version = "$version~$1";
+ return $version;
+ }
+ if (
+ $uri =~ m{ \A
+ https?://www\.debian\.org/doc/
+ (?:packaging-manuals/)?copyright-format/(\d+\.\d+)/?
+ \Z}xsm
+ ){
+ $version = $1;
+ return $version;
+ }
+
+ $self->pointed_hint('unknown-copyright-format-uri',
+ $file->pointer, $original_uri);
+
+ return undef;
+}
+
+sub check_dep5_copyright {
+ my ($self, $copyright_file) = @_;
+
+ my $contents = $copyright_file->decoded_utf8;
+
+ if ($contents =~ /^Files-Excluded:/m) {
+
+ if ($contents
+ =~ m{^Format:.*/doc/packaging-manuals/copyright-format/1.0/?$}m) {
+
+ $self->pointed_hint('repackaged-source-not-advertised',
+ $copyright_file->pointer)
+ unless $self->processable->repacked
+ || $self->processable->native;
+
+ } else {
+ $self->pointed_hint('files-excluded-without-copyright-format-1.0',
+ $copyright_file->pointer);
+ }
+ }
+
+ unless (
+ $contents =~ m{
+ (?:^ | \n)
+ (?i: format(?: [:] |[-\s]spec) )
+ (?: . | \n\s+ )*
+ (?: /dep[5s]?\b | \bDEP ?5\b
+ | [Mm]achine-readable\s(?:license|copyright)
+ | /copyright-format/ | CopyrightFormat
+ | VERSIONED_FORMAT_URL
+ ) }x
+ ){
+
+ $self->pointed_hint('no-dep5-copyright', $copyright_file->pointer);
+ return;
+ }
+
+ # get format before parsing as a debian control file
+ my $first_para = $contents;
+ $first_para =~ s/^#.*//mg;
+ $first_para =~ s/[ \t]+$//mg;
+ $first_para =~ s/^\n+//g;
+ $first_para =~ s/\n\n.*/\n/s; #;; hi emacs
+ $first_para =~ s/\n?[ \t]+/ /g;
+
+ if ($first_para !~ /^Format(?:-Specification)?:\s*(\S+)\s*$/mi) {
+ $self->pointed_hint('unknown-copyright-format-uri',
+ $copyright_file->pointer);
+ return;
+ }
+
+ my $uri = $1;
+
+ # strip fragment identifier
+ $uri =~ s/^([^#\s]+)#/$1/;
+
+ my $version = $self->find_dep5_version($copyright_file, $uri);
+ return
+ unless defined $version;
+
+ if ($version =~ /wiki/) {
+ $self->pointed_hint('wiki-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+
+ } elsif ($version =~ /svn$/) {
+ $self->pointed_hint('unversioned-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+
+ } elsif (versions_compare($version, '<<', $LAST_SIGNIFICANT_DEP5_CHANGE)) {
+ $self->pointed_hint('out-of-date-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+
+ } elsif ($uri =~ m{^http://www\.debian\.org/}) {
+ $self->pointed_hint('insecure-copyright-format-uri',
+ $copyright_file->pointer, $uri);
+ }
+
+ return
+ if versions_compare($version, '<<', $LAST_DEP5_OVERHAUL);
+
+ # probably DEP 5 format; let's try more checks
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->read_file($copyright_file->unpacked_path);
+
+ } catch {
+ my $error = $@;
+ chomp $error;
+ $error =~ s{^syntax error in }{};
+
+ $self->pointed_hint('syntax-error-in-dep5-copyright',
+ $copyright_file->pointer, $@);
+
+ return;
+ }
+
+ return
+ unless @sections;
+
+ my %found_standalone;
+ my %license_names_by_section;
+ my %license_text_by_section;
+ my %license_identifier_by_section;
+
+ my @license_sections = grep { $_->declares('License') } @sections;
+ for my $section (@license_sections) {
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('tab-in-license-text', $pointer)
+ if $section->untrimmed_value('License') =~ /\t/;
+
+ my ($anycase_identifier, $license_text)
+ = split(/\n/, $section->untrimmed_value('License'), 2);
+
+ $anycase_identifier //= $EMPTY;
+ $license_text //= $EMPTY;
+
+ # replace some weird characters
+ $anycase_identifier =~ s/[(),]/ /g;
+
+ # trim both ends
+ $anycase_identifier =~ s/^\s+|\s+$//g;
+ $license_text =~ s/^\s+|\s+$//g;
+
+ my $license_identifier = lc $anycase_identifier;
+
+ my @license_names
+ = grep { length } split(/\s+(?:and|or)\s+/, $license_identifier);
+
+ $license_names_by_section{$section->position} = \@license_names;
+ $license_text_by_section{$section->position} = $license_text;
+ $license_identifier_by_section{$section->position}
+ = $license_identifier;
+
+ $self->pointed_hint('empty-short-license-in-dep5-copyright', $pointer)
+ unless length $license_identifier;
+
+ $self->pointed_hint('pipe-symbol-used-as-license-disjunction',
+ $pointer, $license_identifier)
+ if $license_identifier =~ m{\s+\|\s+};
+
+ for my $name (@license_names) {
+ if ($name =~ /\s/) {
+
+ if($name =~ /[^ ]+ \s+ with \s+ (.*)/x) {
+
+ my $exceptiontext = $1;
+
+ $self->pointed_hint(
+ 'bad-exception-format-in-dep5-copyright',
+ $pointer, $name)
+ unless $exceptiontext =~ /[^ ]+ \s+ exception/x;
+
+ } else {
+
+ $self->pointed_hint(
+ 'space-in-std-shortname-in-dep5-copyright',
+ $pointer, $name);
+ }
+ }
+
+ $self->pointed_hint('invalid-short-name-in-dep5-copyright',
+ $pointer, $name)
+ if $name =~ m{^(?:agpl|gpl|lgpl)[^-]?\d(?:\.\d)?\+?$}
+ || $name =~ m{^bsd(?:[^-]?[234][^-]?(?:clause|cluase))?$};
+
+ $self->pointed_hint('license-problem-undefined-license',
+ $pointer, $name)
+ if $name eq $HYPHEN
+ || $name
+ =~ m{\b(?:fixmes?|todos?|undefined?|unknown?|unspecified)\b};
+ }
+
+ # stand-alone license
+ if ( length $license_identifier
+ && length $license_text
+ && !$section->declares('Files')) {
+
+ $found_standalone{$license_identifier} //= [];
+ push(@{$found_standalone{$license_identifier}}, $section);
+ }
+
+ if ($license_identifier =~ /^cc-/ && length $license_text) {
+
+ my $num_lines = $license_text =~ tr/\n//;
+
+ $self->pointed_hint('incomplete-creative-commons-license',
+ $pointer, $license_identifier)
+ if $num_lines < $MINIMUM_CREATIVE_COMMMONS_LENGTH;
+ }
+ }
+
+ my @not_unique
+ = grep { @{$found_standalone{$_}} > 1 } keys %found_standalone;
+ for my $name (@not_unique) {
+
+ next
+ if $name eq 'public-domain';
+
+ for my $section (@{$found_standalone{$name}}) {
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('dep5-copyright-license-name-not-unique',
+ $pointer, $name);
+ }
+ }
+
+ my ($header, @followers) = @sections;
+
+ my @obsolete_fields = grep { $header->declares($_) } keys %NEW_FIELD_NAMES;
+ for my $old_name (@obsolete_fields) {
+
+ my $position = $header->position($old_name);
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('obsolete-field-in-dep5-copyright',
+ $pointer, $old_name, $NEW_FIELD_NAMES{$old_name});
+ }
+
+ my $header_pointer = $copyright_file->pointer($header->position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $header_pointer, 'Format')
+ if none { $header->declares($_) } qw(Format Format-Specification);
+
+ my $debian_control = $self->processable->debian_control;
+
+ $self->pointed_hint('missing-explanation-for-contrib-or-non-free-package',
+ $header_pointer)
+ if $debian_control->source_fields->value('Section')
+ =~ m{^(?:contrib|non-free)(?:/.+)?$}
+ && (none { $header->declares($_) } qw{Comment Disclaimer});
+
+ $self->pointed_hint('missing-explanation-for-repacked-upstream-tarball',
+ $header_pointer)
+ if $self->processable->repacked
+ && $header->value('Source') =~ m{^https?://}
+ && (none { $header->declares($_) } qw{Comment Files-Excluded});
+
+ my @ambiguous_sections = grep {
+ $_->declares('License')
+ && $_->declares('Copyright')
+ && !$_->declares('Files')
+ } @followers;
+
+ $self->pointed_hint(
+ 'ambiguous-paragraph-in-dep5-copyright',
+ $copyright_file->pointer($_->position)
+ )for @ambiguous_sections;
+
+ my @unknown_sections
+ = grep {!$_->declares('License')&& !$_->declares('Files')} @followers;
+
+ $self->pointed_hint(
+ 'unknown-paragraph-in-dep5-copyright',
+ $copyright_file->pointer($_->position)
+ )for @unknown_sections;
+
+ my @shipped_items;
+
+ if ($self->processable->native) {
+ @shipped_items = @{$self->processable->patched->sorted_list};
+
+ } else {
+ @shipped_items = @{$self->processable->orig->sorted_list};
+
+ # remove ./debian folder from orig, if any
+ @shipped_items = grep { !m{^debian/} } @shipped_items
+ if $self->processable->fields->value('Format') eq '3.0 (quilt)';
+
+ # add ./ debian folder from patched
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ push(@shipped_items, $debian_dir->descendants)
+ if $debian_dir;
+ }
+
+ my @shipped_names
+ = sort map { $_->name } grep { $_->is_file } @shipped_items;
+
+ my @excluded;
+ for my $wildcard ($header->trimmed_list('Files-Excluded')) {
+
+ my $position = $header->position('Files-Excluded');
+ my $pointer = $copyright_file->pointer($position);
+
+ my @offenders = escape_errors($wildcard);
+
+ $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright',
+ $pointer, '(Files-Excluded)', $_)
+ for @offenders;
+
+ next
+ if @offenders;
+
+ # also match dir/filename for Files-Excluded: dir
+ unless ($wildcard =~ /\*/ || $wildcard =~ /\?/) {
+
+ my $candidate = $wildcard;
+ $candidate .= $SLASH
+ unless $candidate =~ m{/$};
+
+ my $item = $self->processable->orig->lookup($candidate);
+
+ $wildcard = $candidate . $ASTERISK
+ if defined $item && $item->is_dir;
+ }
+
+ my @match = match_glob($wildcard, @shipped_names);
+
+ # do not flag missing matches; uscan already excluded them
+ push(@excluded, @match);
+ }
+
+ my @included;
+ for my $wildcard ($header->trimmed_list('Files-Included')) {
+
+ my $position = $header->position('Files-Included');
+ my $pointer = $copyright_file->pointer($position);
+
+ my @offenders = escape_errors($wildcard);
+
+ $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright',
+ $pointer, '(Files-Included)', $_)
+ for @offenders;
+
+ next
+ if @offenders;
+
+ # also match dir/filename for Files-Excluded: dir
+ unless ($wildcard =~ /\*/ || $wildcard =~ /\?/) {
+
+ my $candidate = $wildcard;
+ $candidate .= $SLASH
+ unless $candidate =~ m{/$};
+
+ my $item = $self->processable->orig->lookup($candidate);
+
+ $wildcard = $candidate . $ASTERISK
+ if defined $item && $item->is_dir;
+ }
+
+ my @match = match_glob($wildcard, @shipped_names);
+
+ $self->pointed_hint(
+ 'superfluous-file-pattern', $pointer,
+ '(Files-Included)', $wildcard
+ )unless @match;
+
+ push(@included, @match);
+ }
+
+ my $lc = List::Compare->new(\@included, \@excluded);
+ my @affirmed = $lc->get_Lonly;
+ my @unwanted = $lc->get_Ronly;
+
+ # already unique
+ for my $name (@affirmed) {
+
+ my $position = $header->position('Files-Included');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('file-included-already', $pointer, $name);
+ }
+
+ # already unique
+ for my $name (@unwanted) {
+
+ my $position = $header->position('Files-Excluded');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('source-ships-excluded-file',$pointer, $name)
+ unless $name =~ m{^(?:debian|\.pc)/};
+ }
+
+ my @notice_names= grep { m{(^|/)(COPYING[^/]*|LICENSE)$} } @shipped_names;
+ my @quilt_names = grep { m{^\.pc/} } @shipped_names;
+
+ my @names_with_comma = grep { /,/ } @shipped_names;
+ my @fields_with_comma = grep { $_->value('Files') =~ /,/ } @followers;
+
+ for my $section (@fields_with_comma) {
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('comma-separated-files-in-dep5-copyright',$pointer)
+ if !@names_with_comma;
+ }
+
+ # only attempt to evaluate globbing if commas could be legal
+ my $check_wildcards = !@fields_with_comma || @names_with_comma;
+
+ my @files_sections = grep {$_->declares('Files')} @followers;
+
+ for my $section (@files_sections) {
+
+ if (!length $section->value('Files')) {
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $pointer,'(empty field)', 'Files');
+ }
+
+ my $section_pointer = $copyright_file->pointer($section->position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $section_pointer, 'License')
+ if !$section->declares('License');
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $section_pointer, 'Copyright')
+ if !$section->declares('Copyright');
+
+ if ($section->declares('Copyright')
+ && !length $section->value('Copyright')) {
+
+ my $position = $section->position('Copyright');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('missing-field-in-dep5-copyright',
+ $pointer, '(empty field)', 'Copyright');
+ }
+ }
+
+ my %sections_by_wildcard;
+ my %wildcard_by_file;
+ my %required_standalone;
+ my %positions_by_debian_year;
+ my @redundant_wildcards;
+
+ my $section_count = 0;
+ for my $section (@followers) {
+
+ my $wildcard_pointer
+ = $copyright_file->pointer($section->position('Files'));
+
+ my $copyright_pointer
+ = $copyright_file->pointer($section->position('Copyright'));
+
+ my $license_pointer
+ = $copyright_file->pointer($section->position('License'));
+
+ my @license_names
+ = @{$license_names_by_section{$section->position} // []};
+ my $license_text = $license_text_by_section{$section->position};
+
+ if ($section->declares('Files') && !length $license_text) {
+ $required_standalone{$_} = $section for @license_names;
+ }
+
+ my @wildcards;
+
+ # If it is the first paragraph, it might be an instance of
+ # the (no-longer) optional "first Files-field".
+ if ( $section_count == 0
+ && $section->declares('License')
+ && $section->declares('Copyright')
+ && !$section->declares('Files')) {
+
+ @wildcards = ($ASTERISK);
+
+ } else {
+ @wildcards = $section->trimmed_list('Files');
+ }
+
+ my @rightholders = $section->trimmed_list('Copyright', qr{ \n }x);
+ my @years = map { /(\d{4})/g } @rightholders;
+
+ if (any { m{^ debian (?: / | $) }x } @wildcards) {
+
+ my $position = $section->position('Copyright');
+
+ push(@{$positions_by_debian_year{$_}}, $position)for @years;
+ }
+
+ for my $wildcard (@wildcards) {
+ $sections_by_wildcard{$wildcard} //= [];
+ push(@{$sections_by_wildcard{$wildcard}}, $section);
+ }
+
+ $self->pointed_hint(
+ 'global-files-wildcard-not-first-paragraph-in-dep5-copyright',
+ $wildcard_pointer)
+ if (any { $_ eq $ASTERISK } @wildcards) && $section_count > 0;
+
+ # stand-alone license paragraph
+ $self->pointed_hint('missing-license-text-in-dep5-copyright',
+ $license_pointer, $section->untrimmed_value('License'))
+ if !@wildcards
+ && $section->declares('License')
+ && !length $license_text;
+
+ next
+ unless $check_wildcards;
+
+ my %wildcards_same_section_by_file;
+
+ for my $wildcard (@wildcards) {
+
+ my @offenders = escape_errors($wildcard);
+
+ $self->pointed_hint('invalid-escape-sequence-in-dep5-copyright',
+ $wildcard_pointer, $_)
+ for @offenders;
+
+ next
+ if @offenders;
+
+ my @covered = match_glob($wildcard, @shipped_names);
+
+ for my $name (@covered) {
+ $wildcards_same_section_by_file{$name} //= [];
+ push(@{$wildcards_same_section_by_file{$name}}, $wildcard);
+ }
+ }
+
+ my @overwritten = grep { length $wildcard_by_file{$_} }
+ keys %wildcards_same_section_by_file;
+
+ for my $name (@overwritten) {
+
+ my $winning_wildcard
+ = @{$wildcards_same_section_by_file{$name}}[$LAST_ITEM];
+ my $loosing_wildcard = $wildcard_by_file{$name};
+
+ my $winner_depth = ($winning_wildcard =~ tr{/}{});
+ my $looser_depth = ($loosing_wildcard =~ tr{/}{});
+
+ $self->pointed_hint('globbing-patterns-out-of-order',
+ $wildcard_pointer,$loosing_wildcard, $winning_wildcard, $name)
+ if $looser_depth > $winner_depth;
+ }
+
+ # later matches have precendence; depends on section ordering
+ $wildcard_by_file{$_}
+ = @{$wildcards_same_section_by_file{$_}}[$LAST_ITEM]
+ for keys %wildcards_same_section_by_file;
+
+ my @overmatched_same_section
+ = grep { @{$wildcards_same_section_by_file{$_}} > 1 }
+ keys %wildcards_same_section_by_file;
+
+ for my $file (@overmatched_same_section) {
+
+ my $patterns
+ = join($SPACE, sort @{$wildcards_same_section_by_file{$file}});
+
+ $self->pointed_hint('redundant-globbing-patterns',
+ $wildcard_pointer,"($patterns) for $file");
+ }
+
+ push(@redundant_wildcards,
+ map { @{$wildcards_same_section_by_file{$_}} }
+ @overmatched_same_section);
+
+ } continue {
+ $section_count++;
+ }
+
+ my @debian_years = keys %positions_by_debian_year;
+ my @changelog_entries = @{$self->processable->changelog->entries};
+
+ if (@debian_years && @changelog_entries) {
+
+ my @descending = reverse sort { $a <=> $b } @debian_years;
+ my $most_recent_copyright = $descending[0];
+
+ my $tp = Time::Piece->strptime($changelog_entries[0]->Date,
+ '%a, %d %b %Y %T %z');
+ my $most_recent_changelog = $tp->year;
+
+ my @candidates = @{$positions_by_debian_year{$most_recent_copyright}};
+ my @sorted = sort { $a <=> $b } @candidates;
+
+ # pick the topmost, which should be the broadest pattern
+ my $position = $candidates[0];
+
+ $self->pointed_hint('update-debian-copyright',
+ $copyright_file->pointer($position),
+ $most_recent_copyright, 'vs', $most_recent_changelog)
+ if $most_recent_copyright < $most_recent_changelog;
+ }
+
+ if ($check_wildcards) {
+
+ my @duplicate_wildcards= grep { @{$sections_by_wildcard{$_}} > 1 }
+ keys %sections_by_wildcard;
+
+ for my $wildcard (@duplicate_wildcards) {
+
+ my $lines = join($SPACE,
+ map { $_->position('Files') }
+ @{$sections_by_wildcard{$wildcard}});
+
+ $self->pointed_hint('duplicate-globbing-patterns',
+ $copyright_file->pointer,$wildcard, "(lines $lines)");
+ }
+
+ # do not issue next tag for duplicates or redundant wildcards
+ my $wildcard_lc = List::Compare->new(
+ [keys %sections_by_wildcard],
+ [
+ (
+ values %wildcard_by_file, @duplicate_wildcards,
+ @redundant_wildcards
+ )
+ ]
+ );
+ my @matches_nothing = $wildcard_lc->get_Lonly;
+
+ for my $wildcard (@matches_nothing) {
+ for my $section (@{$sections_by_wildcard{$wildcard}}) {
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('superfluous-file-pattern', $pointer,
+ $wildcard);
+ }
+ }
+
+ my %sections_by_file;
+ for my $name (keys %wildcard_by_file) {
+
+ $sections_by_file{$name} //= [];
+ my $wildcard = $wildcard_by_file{$name};
+
+ push(
+ @{$sections_by_file{$name}},
+ @{$sections_by_wildcard{$wildcard}}
+ );
+ }
+
+ my %license_identifiers_by_file;
+ for my $name (keys %sections_by_file) {
+
+ $license_identifiers_by_file{$name} //= [];
+
+ push(
+ @{$license_identifiers_by_file{$name}},
+ $license_identifier_by_section{$_->position}
+ ) for @{$sections_by_file{$name}};
+ }
+
+ my @xml_searchspace = keys %license_identifiers_by_file;
+
+ # do not examine Lintian's test suite for appstream metadata
+ @xml_searchspace = grep { !m{t/} } @xml_searchspace
+ if $self->processable->name eq 'lintian';
+
+ for my $name (@xml_searchspace) {
+
+ next
+ if $name =~ '^\.pc/';
+
+ next
+ unless $name =~ /\.xml$/;
+
+ my $parser = XML::LibXML->new;
+ $parser->set_option('no_network', 1);
+
+ my $file = $self->processable->patched->resolve_path($name);
+ my $doc;
+ try {
+ $doc = $parser->parse_file($file->unpacked_path);
+
+ } catch {
+ next;
+ }
+
+ next
+ unless $doc;
+
+ my @nodes = $doc->findnodes('/component/metadata_license');
+ next
+ unless @nodes;
+
+ # take first one
+ my $first = $nodes[0];
+ next
+ unless $first;
+
+ my $seen = lc($first->firstChild->data // $EMPTY);
+ next
+ unless $seen;
+
+ # Compare and also normalize the seen and wanted license
+ # identifier wrt. to redundant trailing dot-zeros,
+ # -or-later suffix vs + suffix, -only suffix vs no
+ # suffix. Still display the original variant in the tag.
+ my $seen_normalized = $seen;
+ $seen_normalized = 'expat' if $seen_normalized eq 'mit';
+ $seen_normalized =~ s/-or-later$/+/i;
+ $seen_normalized =~ s/-only$//i;
+ my $seen_nozero = $seen_normalized;
+ $seen_nozero =~ s/\.0//g;
+
+ my @wanted = @{$license_identifiers_by_file{$name}};
+ my @mismatched = grep {
+ my $want = $_;
+ my $want_normalized = $want;
+ $want_normalized = 'expat' if $want_normalized eq 'mit';
+ $want_normalized =~ s/-or-later$/+/i;
+ $want_normalized =~ s/-only$//i;
+ my $want_nozero = $want_normalized;
+ $want_nozero =~ s/\.0//g;
+
+ $want_normalized ne $seen_normalized
+ and $want_nozero ne $seen_normalized
+ and $want_normalized ne $seen_nozero
+ and $want_nozero ne $seen_nozero;
+ } @wanted;
+
+ $self->pointed_hint('inconsistent-appstream-metadata-license',
+ $copyright_file->pointer, $name, "($seen != $_)")
+ for @mismatched;
+ }
+
+ my @no_license_needed = (@quilt_names, @notice_names);
+ my $unlicensed_lc
+ = List::Compare->new(\@shipped_names, \@no_license_needed);
+ my @license_needed = $unlicensed_lc->get_Lonly;
+
+ my @not_covered
+ = grep { !@{$sections_by_file{$_} // []} } @license_needed;
+
+ $self->pointed_hint('file-without-copyright-information',
+ $copyright_file->pointer, $_)
+ for @not_covered;
+ }
+
+ my $standalone_lc= List::Compare->new([keys %required_standalone],
+ [keys %found_standalone]);
+ my @missing_standalone = $standalone_lc->get_Lonly;
+ my @matched_standalone = $standalone_lc->get_intersection;
+ my @unused_standalone = $standalone_lc->get_Ronly;
+
+ for my $license (@missing_standalone) {
+
+ my $section = $required_standalone{$license};
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('missing-license-paragraph-in-dep5-copyright',
+ $pointer, $license);
+ }
+
+ for my $license (grep { $_ ne 'public-domain' } @unused_standalone) {
+
+ for my $section (@{$found_standalone{$license}}) {
+
+ my $position = $section->position('License');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('unused-license-paragraph-in-dep5-copyright',
+ $pointer, $license);
+ }
+ }
+
+ for my $license (@matched_standalone) {
+
+ my $section = $required_standalone{$license};
+
+ my $position = $section->position('Files');
+ my $pointer = $copyright_file->pointer($position);
+
+ $self->pointed_hint('dep5-file-paragraph-references-header-paragraph',
+ $pointer, $license)
+ if all { $_ == $header } @{$found_standalone{$license}};
+ }
+
+ # license files do not require their own entries in d/copyright.
+ my $license_lc
+ = List::Compare->new(\@notice_names, [keys %sections_by_wildcard]);
+ my @listed_licenses = $license_lc->get_intersection;
+
+ $self->pointed_hint('license-file-listed-in-debian-copyright',
+ $copyright_file->pointer, $_)
+ for @listed_licenses;
+
+ return;
+}
+
+sub escape_errors {
+ my ($escaped) = @_;
+
+ my @sequences = ($escaped =~ m{\\.?}g);
+ my @illegal = grep { !m{^\\[*?]$} } @sequences;
+
+ return @illegal;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm b/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm
new file mode 100644
index 0000000..453a40b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm
@@ -0,0 +1,109 @@
+# debian/copyright/dep5/components -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Copyright::Dep5::Components;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::Compare;
+use Syntax::Keyword::Try;
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my @installables = $self->processable->debian_control->installables;
+ my @additional = map { $_ . '.copyright' } @installables;
+
+ my @candidates = ('copyright', @additional);
+ my @files = grep { defined $_ && !$_->is_symlink }
+ map { $debian_dir->child($_) } @candidates;
+
+ # another check complains about legacy encoding, if needed
+ my @valid_utf8 = grep { $_->is_valid_utf8 } @files;
+
+ $self->check_dep5_copyright($_) for @valid_utf8;
+
+ return;
+}
+
+sub check_dep5_copyright {
+ my ($self, $copyright_file) = @_;
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->read_file($copyright_file->unpacked_path);
+
+ } catch {
+ # may not be in DEP 5 format
+ return;
+ }
+
+ return
+ unless @sections;
+
+ my ($header, @followers) = @sections;
+
+ my @initial_path_components;
+
+ for my $section (@followers) {
+
+ my @subdirs = $section->trimmed_list('Files');
+ s{ / .* $}{}x for @subdirs;
+
+ my @definite = grep { !/[*?]/ } @subdirs;
+
+ push(@initial_path_components, grep { length } @definite);
+ }
+
+ my @extra_source_components
+ = grep { length } values %{$self->processable->components};
+ my $component_lc = List::Compare->new(\@extra_source_components,
+ \@initial_path_components);
+
+ my @missing_components = $component_lc->get_Lonly;
+
+ $self->pointed_hint('add-component-copyright', $copyright_file->pointer,$_)
+ for @missing_components;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Debconf.pm b/lib/Lintian/Check/Debian/Debconf.pm
new file mode 100644
index 0000000..6b86bf9
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Debconf.pm
@@ -0,0 +1,794 @@
+# debian/debconf -- lintian check script -*- perl -*-
+
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2020-21 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Debconf;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(none);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822;
+use Lintian::Deb822::Constants qw(DCTRL_DEBCONF_TEMPLATE);
+use Lintian::Relation;
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+const my $MAXIMUM_TEMPLATE_SYNOPSIS => 75;
+const my $MAXIMUM_LINE_LENGTH => 80;
+const my $MAXIMUM_LINES => 20;
+const my $ITEM_NOT_FOUND => -1;
+
+# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
+# version 1.5.24. Added indices for cdebconf (indicates sort order for
+# choices); debconf doesn't support it, but it ignores it, which is safe
+# behavior. Likewise, help is supported as of cdebconf 0.143 but is not yet
+# supported by debconf.
+my %template_fields
+ = map { $_ => 1 } qw(Template Type Choices Indices Default Description Help);
+
+# From debconf-devel(7), section 'THE TEMPLATES FILE', up to date with debconf
+# version 1.5.24.
+my %valid_types = map { $_ => 1 } qw(
+ string
+ password
+ boolean
+ select
+ multiselect
+ note
+ error
+ title
+ text);
+
+# From debconf-devel(7), section 'THE DEBCONF PROTOCOL' under 'INPUT', up to
+# date with debconf version 1.5.24.
+my %valid_priorities = map { $_ => 1 } qw(low medium high critical);
+
+# All the packages that provide debconf functionality. Anything using debconf
+# needs to have dependencies that satisfy one of these.
+my $ANY_DEBCONF = Lintian::Relation->new->load(
+ join(
+ ' | ', qw(debconf debconf-2.0 cdebconf
+ cdebconf-udeb libdebconfclient0 libdebconfclient0-udeb)
+ )
+);
+
+sub source {
+ my ($self) = @_;
+
+ my @catalogs= (
+ 'templates',
+ map { "$_.templates" }$self->processable->debian_control->installables
+ );
+ my @files = grep { defined }
+ map { $self->processable->patched->resolve_path("debian/$_") } @catalogs;
+
+ my @utf8 = grep { $_->is_valid_utf8 and $_->is_file } @files;
+ for my $item (@utf8) {
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @templates;
+ try {
+ @templates
+ = $deb822->read_file($item->unpacked_path,
+ DCTRL_DEBCONF_TEMPLATE);
+
+ } catch {
+ my $error = $@;
+ chomp $error;
+ $error =~ s{^syntax error in }{};
+
+ $self->pointed_hint('syntax-error-in-debconf-template',
+ $item->pointer, $error);
+
+ next;
+ }
+
+ my @unsplit_choices
+ = grep {$_->declares('Template') && $_->declares('_Choices')}
+ @templates;
+
+ $self->pointed_hint(
+ 'template-uses-unsplit-choices',
+ $item->pointer($_->position('_Choices')),
+ $_->value('Template')
+ )for @unsplit_choices;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $usespreinst;
+ my $preinst = $self->processable->control->lookup('preinst');
+
+ if ($preinst and $preinst->is_file and $preinst->is_open_ok) {
+
+ open(my $fd, '<', $preinst->unpacked_path)
+ or die encode_utf8('Cannot open ' . $preinst->unpacked_path);
+
+ while (my $line = <$fd>) {
+ $line =~ s/\#.*//; # Not perfect for Perl, but should be OK
+
+ if ( $line =~ m{/usr/share/debconf/confmodule}
+ || $line =~ /(?:Debconf|Debian::DebConf)::Client::ConfModule/){
+ $usespreinst=1;
+
+ last;
+ }
+ }
+ close($fd);
+ }
+
+ my $seenconfig;
+ my $ctrl_config = $self->processable->control->lookup('config');
+ if (defined $ctrl_config && $ctrl_config->is_file) {
+
+ $self->pointed_hint('debconf-config-not-executable',
+ $ctrl_config->pointer)
+ unless $ctrl_config->is_executable;
+
+ $seenconfig = 1;
+ }
+
+ my $seentemplates;
+ my $ctrl_templates = $self->processable->control->lookup('templates');
+ $seentemplates = 1 if $ctrl_templates and $ctrl_templates->is_file;
+
+ # This still misses packages that use debconf only in the postrm.
+ # Packages that ask debconf questions in the postrm should load
+ # the confmodule in the postinst so that debconf can register
+ # their templates.
+ return
+ unless $seenconfig
+ or $seentemplates
+ or $usespreinst;
+
+ # parse depends info for later checks
+
+ # Consider every package to depend on itself.
+ my $selfrel;
+ if ($self->processable->fields->declares('Version')) {
+ my $version = $self->processable->fields->value('Version');
+ $selfrel = $self->processable->name . " (= $version)";
+ } else {
+ $selfrel = $self->processable->name;
+ }
+
+ # Include self and provides as a package providing debconf presumably
+ # satisfies its own use of debconf (if any).
+ my $selfrelation
+ = $self->processable->relation('Provides')->logical_and($selfrel);
+ my $alldependencies
+ = $self->processable->relation('strong')->logical_and($selfrelation);
+
+ # See if the package depends on dbconfig-common. Packages that do
+ # are allowed to have a config file with no templates, since they
+ # use the dbconfig-common templates.
+ my $usesdbconfig = $alldependencies->satisfies('dbconfig-common');
+
+ # Check that both debconf control area files are present.
+ if ($seenconfig and not $seentemplates and not $usesdbconfig) {
+
+ $self->hint('no-debconf-templates');
+
+ } elsif ($seentemplates
+ and not $seenconfig
+ and not $usespreinst
+ and $self->processable->type ne 'udeb') {
+
+ $self->hint('no-debconf-config');
+ }
+
+ # Lots of template checks.
+
+ my @templates;
+ if ($seentemplates) {
+
+ if ($ctrl_templates->is_valid_utf8) {
+ my $deb822 = Lintian::Deb822->new;
+
+ try {
+ # $seentemplates (above) will be false if $ctrl_templates is a
+ # symlink or not a file, so this should be safe without
+ # (re-checking) with -f/-l.
+ @templates= $deb822->read_file($ctrl_templates->unpacked_path,
+ DCTRL_DEBCONF_TEMPLATE);
+
+ } catch {
+ my $error = $@;
+ chomp $error;
+ $error =~ s{^syntax error in }{};
+
+ $self->pointed_hint('syntax-error-in-debconf-template',
+ $ctrl_templates->pointer, $error);
+
+ @templates = ();
+ }
+ }
+ }
+
+ my %template_by_name;
+ my %potential_db_abuse;
+ for my $template (@templates) {
+
+ my $isselect = $EMPTY;
+ my $name = $template->value('Template');
+
+ if (!$template->declares('Template')) {
+ $self->pointed_hint('no-template-name',
+ $ctrl_templates->pointer($template->position));
+ $name = 'no-template-name';
+
+ } else {
+ $template_by_name{$name} = $template;
+
+ $self->pointed_hint('malformed-template-name',
+ $ctrl_templates->pointer($template->position('Template')),
+ $name)
+ unless $name =~ m{[A-Za-z0-9.+-](?:/[A-Za-z0-9.+-])};
+ }
+
+ my $type = $template->value('Type');
+ if (!$template->declares('Type')) {
+
+ $self->pointed_hint('no-template-type',
+ $ctrl_templates->pointer($template->position), $name);
+
+ } elsif (!$valid_types{$type}) {
+
+ # cdebconf has a special "entropy" type
+ $self->pointed_hint('unknown-template-type',
+ $ctrl_templates->pointer($template->position('Type')), $type)
+ unless $type eq 'entropy'
+ && $alldependencies->satisfies('cdebconf');
+
+ } elsif ($type eq 'select' || $type eq 'multiselect') {
+ $isselect = 1;
+
+ } elsif ($type eq 'boolean') {
+
+ my $default = $template->value('Default');
+
+ $self->pointed_hint(
+ 'boolean-template-has-bogus-default',
+ $ctrl_templates->pointer($template->position('Default')),
+ $name, $default
+ )
+ if $template->declares('Default')
+ && (none { $default eq $_ } qw(true false));
+ }
+
+ my $choices = $template->value('Choices');
+ if ($template->declares('Choices') && $choices !~ /^\s*$/) {
+
+ my $nrchoices = count_choices($choices);
+ for my $key ($template->names) {
+
+ if ($key =~ /^Choices-/) {
+ my $translated = $template->value($key);
+
+ if (!length($translated) || $translated =~ /^\s*$/){
+ $self->pointed_hint(
+ 'empty-translated-choices',
+ $ctrl_templates->pointer(
+ $template->position('Choices')
+ ),
+ $name, $key
+ );
+ }
+
+ if (count_choices($translated) != $nrchoices) {
+ $self->pointed_hint(
+ 'mismatch-translated-choices',
+ $ctrl_templates->pointer(
+ $template->position('Choices')
+ ),
+ $name,$key
+ );
+ }
+ }
+ }
+
+ $self->pointed_hint('select-with-boolean-choices',
+ $ctrl_templates->pointer($template->position('Choices')),$name)
+ if $choices =~ /^\s*(yes\s*,\s*no|no\s*,\s*yes)\s*$/i;
+ }
+
+ $self->pointed_hint('select-without-choices',
+ $ctrl_templates->pointer($template->position), $name)
+ if $isselect && !$template->declares('Choices');
+
+ my $description = $template->value('Description');
+
+ $self->pointed_hint('no-template-description',
+ $ctrl_templates->pointer($template->position), $name)
+ unless length $description
+ || length $template->value('_Description');
+
+ if ($description =~ /^\s*(.*?)\s*?\n\s*\1\s*$/){
+
+ # Check for duplication. Should all this be folded into the
+ # description checks?
+ $self->pointed_hint('duplicate-long-description-in-template',
+ $ctrl_templates->pointer($template->position('Description')),
+ $name);
+ }
+
+ my %languages;
+ for my $field ($template->names) {
+ # Tests on translations
+ my ($mainfield, $lang) = split m/-/, $field, 2;
+ if (defined $lang) {
+ $languages{$lang}{$mainfield}=1;
+ }
+ my $stripped = $mainfield;
+ $stripped =~ s/^_//;
+ unless ($template_fields{$stripped}) {
+ # Ignore language codes here
+ $self->pointed_hint('unknown-field-in-templates',
+ $ctrl_templates->pointer($template->position($field)),
+ $name, $field);
+ }
+ }
+
+ if (length $name && length $type) {
+ $potential_db_abuse{$name} = 1
+ if $type eq 'note' || $type eq 'text';
+ }
+
+ # Check the description against the best practices in the
+ # Developer's Reference, but skip all templates where the
+ # short description contains the string "for internal use".
+ my ($short, $extended);
+ if (length $description) {
+ ($short, $extended) = split(/\n/, $description, 2);
+ unless (defined $short) {
+ $short = $description;
+ $extended = $EMPTY;
+ }
+ } else {
+ $short = $EMPTY;
+ $extended = $EMPTY;
+ }
+
+ my $ttype = $type;
+ unless ($short =~ /for internal use/i) {
+
+ my $pointer
+ = $ctrl_templates->pointer($template->position('Description'));
+
+ my $isprompt = grep { $_ eq $ttype } qw(string password);
+ if ($isprompt) {
+ if (
+ $short
+ && ( $short !~ m/:$/
+ || $short =~ m/^(what|who|when|where|which|how)/i)
+ ) {
+ $self->pointed_hint('malformed-prompt-in-templates',
+ $pointer, $name);
+ }
+ }
+ if ($isselect) {
+ if ($short =~ /^(Please|Cho+se|Enter|Select|Specify|Give)/) {
+ $self->pointed_hint('using-imperative-form-in-templates',
+ $pointer, $name);
+ }
+ }
+ if ($ttype eq 'boolean') {
+ if ($short !~ /\?/) {
+ $self->pointed_hint('malformed-question-in-templates',
+ $pointer, $name);
+ }
+ }
+ if (defined $extended && $extended =~ /[^\?]\?(\s+|$)/) {
+ $self->pointed_hint(
+ 'using-question-in-extended-description-in-templates',
+ $pointer, $name);
+ }
+ if ($ttype eq 'note') {
+ if ($short =~ /[.?;:]$/) {
+ $self->pointed_hint('malformed-title-in-templates',
+ $pointer, $name);
+ }
+ }
+ if (length $short > $MAXIMUM_TEMPLATE_SYNOPSIS) {
+ $self->pointed_hint('too-long-short-description-in-templates',
+ $pointer, $name)
+ unless $self->processable->type eq 'udeb'
+ && $ttype eq 'text';
+ }
+ if (defined $description) {
+ if ($description
+ =~ /(\A|\s)(I|[Mm]y|[Ww]e|[Oo]ur|[Oo]urs|mine|myself|ourself|me|us)(\Z|\s)/
+ ) {
+ $self->pointed_hint('using-first-person-in-templates',
+ $pointer,$name);
+ }
+ if ( $description =~ /[ \'\"]yes[ \'\",;.]/i
+ and $ttype eq 'boolean') {
+
+ $self->pointed_hint(
+ 'making-assumptions-about-interfaces-in-templates',
+ $pointer, $name);
+ }
+ }
+
+ # Check whether the extended description is too long.
+ if ($extended) {
+
+ my $lines = 0;
+ for my $string (split(/\n/, $extended)) {
+
+ while (length $string > $MAXIMUM_LINE_LENGTH) {
+
+ my $index
+ = rindex($string, $SPACE, $MAXIMUM_LINE_LENGTH);
+
+ if ($index == $ITEM_NOT_FOUND) {
+ $index = index($string, $SPACE);
+ }
+
+ if ($index == $ITEM_NOT_FOUND) {
+ $string = $EMPTY;
+
+ } else {
+ $string = substr($string, $index + 1);
+ $lines++;
+ }
+ }
+
+ $lines++;
+ }
+
+ if ($lines > $MAXIMUM_LINES) {
+ $self->pointed_hint(
+ 'too-long-extended-description-in-templates',
+ $pointer, $name);
+ }
+ }
+ }
+ }
+
+ # Check the maintainer scripts.
+
+ my ($config_calls_db_input, $db_purge);
+ my (%templates_used, %template_aliases);
+ for my $file (qw(config prerm postrm preinst postinst)) {
+
+ my $potential_makedev = {};
+
+ my $item = $self->processable->control->lookup($file);
+
+ if (defined $item && $item->is_file && $item->is_open_ok) {
+
+ my ($usesconfmodule, $obsoleteconfmodule, $db_input, $isdefault);
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ # Only check scripts.
+ my $fl = <$fd>;
+ unless ($fl && $fl =~ /^\#!/) {
+ close($fd);
+ next;
+ }
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # not perfect for Perl, but should be OK
+ $line =~ s/#.*//;
+
+ next
+ unless $line =~ /\S/;
+
+ while ($line =~ s{\\$}{}) {
+ my $next = <$fd>;
+ ++$position;
+
+ last
+ unless $next;
+
+ $line .= $next;
+ }
+
+ if ($line =~ m{(?:\.|source)\s+/usr/share/debconf/confmodule}
+ || $line=~ /(?:use|require)\s+Debconf::Client::ConfModule/)
+ {
+ $usesconfmodule=1;
+ }
+
+ my $pointer = $item->pointer($position);
+
+ if (
+ !$obsoleteconfmodule
+ && $line =~ m{(/usr/share/debconf/confmodule\.sh|
+ Debian::DebConf::Client::ConfModule)}x
+ ) {
+ my $module = $1;
+
+ $self->pointed_hint('loads-obsolete-confmodule', $pointer,
+ $module);
+
+ $usesconfmodule = 1;
+ $obsoleteconfmodule = 1;
+ }
+
+ if ($item->name eq 'config' && $line =~ /db_input/) {
+ $config_calls_db_input = 1;
+ }
+
+ if ( $item->name eq 'postinst'
+ && !$db_input
+ && $line =~ /db_input/
+ && !$config_calls_db_input) {
+
+ # TODO: Perl?
+ $self->pointed_hint('postinst-uses-db-input', $pointer)
+ unless $self->processable->type eq 'udeb';
+ $db_input=1;
+ }
+
+ if ($line =~ m{/dev/}) {
+ $potential_makedev->{$position} = 1;
+ }
+
+ if (
+ $line =~m{\A \s*(?:db_input|db_text)\s+
+ [\"\']? (\S+?) [\"\']? \s+ (\S+)\s}xsm
+ ) {
+ my $priority = $1;
+ my $unmangled = $2;
+
+ $templates_used{$self->get_template_name($unmangled)}= 1;
+
+ if ($priority !~ /^\$\S+$/) {
+
+ $self->pointed_hint('unknown-debconf-priority',
+ $pointer, $priority)
+ unless ($valid_priorities{$priority});
+
+ $self->pointed_hint('possible-debconf-note-abuse',
+ $pointer, $unmangled)
+ if (
+ $potential_db_abuse{$unmangled}
+ and (
+ not($potential_makedev->{($position - 1)}
+ and ($priority eq 'low'))
+ )
+ and ($priority eq 'low' || $priority eq 'medium')
+ );
+ }
+ }
+
+ if (
+ $line =~m{ \A \s* (?:db_get|db_set(?:title)?) \s+
+ [\"\']? (\S+?) [\"\']? (?:\s|\Z)}xsm
+ ) {
+ $templates_used{$self->get_template_name($1)} = 1;
+ }
+
+ # Try to handle Perl somewhat.
+ if ($line =~ /^\s*(?:.*=\s*get|set)\s*\(\s*[\"\'](\S+?)[\"\']/
+ || $line
+ =~ /\b(?:metaget|settitle)\s*\(\s*[\"\'](\S+?)[\"\']/) {
+ $templates_used{$1} = 1;
+ }
+
+ if ($line=~ /^\s*db_register\s+[\"\']?(\S+?)[\"\']?\s+(\S+)\s/)
+ {
+ my ($template, $question) = ($1, $2);
+ push @{$template_aliases{$template}}, $question;
+ }
+ if (!$isdefault && $line =~ /db_fset.*isdefault/) {
+ # TODO: Perl?
+ $self->pointed_hint('isdefault-flag-is-deprecated',
+ $pointer);
+ $isdefault = 1;
+ }
+
+ if (!$db_purge && $line =~ /db_purge/) { # TODO: Perl?
+ $db_purge = 1;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ if ($self->processable->type ne 'udeb') {
+ if ($item->name eq 'config'
+ || ($seenconfig && $item->name eq 'postinst')){
+
+ $self->pointed_hint("$file-does-not-load-confmodule",
+ $item->pointer)
+ unless $usesconfmodule;
+ }
+ }
+
+ if ($item->name eq 'postrm') {
+ # If we haven't seen db_purge we emit the tag unless the
+ # package is a debconf provider (in which case db_purge
+ # won't be available)
+ unless ($db_purge or $selfrelation->satisfies($ANY_DEBCONF)) {
+
+ $self->pointed_hint('postrm-does-not-purge-debconf',
+ $item->pointer);
+ }
+ }
+
+ } elsif ($file eq 'postinst') {
+
+ $self->hint('postinst-does-not-load-confmodule', $file)
+ if $self->processable->type ne 'udeb' && $seenconfig;
+
+ } elsif ($file eq 'postrm') {
+ # Make an exception for debconf providing packages as some of
+ # them (incl. "debconf" itself) cleans up in prerm and have no
+ # postrm script at all.
+ $self->hint('postrm-does-not-purge-debconf', $file)
+ unless $self->processable->type eq 'udeb'
+ or $selfrelation->satisfies($ANY_DEBCONF);
+ }
+ }
+
+ for my $name (keys %template_by_name) {
+
+ $name =~ s/\s+\Z//;
+
+ my $used = 0;
+
+ if ($templates_used{$name}) {
+ $used = 1;
+ } else {
+ foreach my $alias (@{$template_aliases{$name}}) {
+ if ($templates_used{$alias}) {
+ $used = 1;
+ last;
+ }
+ }
+ }
+
+ my $template = $template_by_name{$name};
+ my $position = $template->position('Template');
+ my $pointer = $ctrl_templates->pointer($position);
+
+ $self->pointed_hint('unused-debconf-template', $pointer, $name)
+ unless $name =~ m{^shared/packages-(wordlist|ispell)$}
+ || $name =~ m{/languages$}
+ || $used
+ || $self->processable->name eq 'debconf'
+ || $self->processable->type eq 'udeb';
+ }
+
+ # Check that the right dependencies are in the control file. Accept any
+ # package that might provide debconf functionality.
+
+ if ($usespreinst) {
+ unless ($self->processable->relation('Pre-Depends')
+ ->satisfies($ANY_DEBCONF)){
+ $self->hint('missing-debconf-dependency-for-preinst')
+ unless $self->processable->type eq 'udeb';
+ }
+ } else {
+ unless ($alldependencies->satisfies($ANY_DEBCONF) or $usesdbconfig) {
+ $self->hint('missing-debconf-dependency');
+ }
+ }
+
+ # Now make sure that no scripts are using debconf as a registry.
+ # Unfortunately this requires us to unpack to level 2 and grep all the
+ # scripts in the package.
+ # the following checks is ignored if the package being checked is debconf
+ # itself.
+
+ return
+ if ($self->processable->name eq 'debconf')
+ || ($self->processable->type eq 'udeb');
+
+ my @scripts
+ = grep { $_->is_script } @{$self->processable->installed->sorted_list};
+ for my $item (@scripts) {
+
+ next
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # Not perfect for Perl, but should be OK
+ $line =~ s/#.*//;
+
+ if ( $line =~ m{/usr/share/debconf/confmodule}
+ || $line =~ /(?:Debconf|Debian::DebConf)::Client::ConfModule/){
+
+ $self->pointed_hint('debconf-is-not-a-registry',
+ $item->pointer($position));
+ last;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+} # </run>
+
+# -----------------------------------
+
+# Count the number of choices. Splitting code copied from debconf 1.5.8
+# (Debconf::Question).
+sub count_choices {
+ my ($choices) = @_;
+ my @items;
+ my $item = $EMPTY;
+ for my $chunk (split /(\\[, ]|,\s+)/, $choices) {
+ if ($chunk =~ /^\\([, ])$/) {
+ $item .= $1;
+ } elsif ($chunk =~ /^,\s+$/) {
+ push(@items, $item);
+ $item = $EMPTY;
+ } else {
+ $item .= $chunk;
+ }
+ }
+ push(@items, $item) if $item ne $EMPTY;
+ return scalar(@items);
+}
+
+# Manually interpolate shell variables, eg. $DPKG_MAINTSCRIPT_PACKAGE
+sub get_template_name {
+ my ($self, $name) = @_;
+
+ my $package = $self->processable->name;
+ return $name =~ s/^\$DPKG_MAINTSCRIPT_PACKAGE/$package/r;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/DesktopEntries.pm b/lib/Lintian/Check/Debian/DesktopEntries.pm
new file mode 100644
index 0000000..cff6042
--- /dev/null
+++ b/lib/Lintian/Check/Debian/DesktopEntries.pm
@@ -0,0 +1,58 @@
+# debian/desktop-entries -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::DesktopEntries;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ if $self->processable->native;
+
+ my $debiandir = $self->processable->patched->resolve_path('debian');
+ return
+ unless $debiandir;
+
+ my @files = grep { $_->is_file } $debiandir->descendants;
+ my @nopatches = grep { $_->name !~ m{^debian/patches/} } @files;
+
+ my @manpages = grep { $_->basename =~ m{\.desktop$} } @nopatches;
+
+ $self->pointed_hint('maintainer-desktop-entry', $_->pointer) for @manpages;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Filenames.pm b/lib/Lintian/Check/Debian/Filenames.pm
new file mode 100644
index 0000000..c18b129
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Filenames.pm
@@ -0,0 +1,78 @@
+# debian/filenames -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Filenames;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ # names are different in installation packages (see #429510)
+ # README and TODO may be handled differently
+
+ my @often_misnamed = (
+ { correct => 'NEWS', problematic => 'NEWS.Debian' },
+ { correct => 'NEWS', problematic => 'NEWS.debian' },
+ { correct => 'TODO', problematic => 'TODO.Debian' },
+ { correct => 'TODO', problematic => 'TODO.debian' }
+ );
+
+ for my $relative (@often_misnamed) {
+
+ my $problematic_item = $self->processable->patched->resolve_path(
+ 'debian/' . $relative->{problematic});
+
+ next
+ unless defined $problematic_item;
+
+ my $correct_name = 'debian/' . $relative->{correct};
+ if ($self->processable->patched->resolve_path($correct_name)) {
+
+ $self->pointed_hint('duplicate-packaging-file',
+ $problematic_item->pointer,
+ 'better:', $correct_name);
+
+ } else {
+ $self->pointed_hint(
+ 'incorrect-packaging-filename',
+ $problematic_item->pointer,
+ 'better:', $correct_name
+ );
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Files.pm b/lib/Lintian/Check/Debian/Files.pm
new file mode 100644
index 0000000..921f48b
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Files.pm
@@ -0,0 +1,60 @@
+# debian/files -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Files;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->name eq 'debian/files';
+
+ $self->pointed_hint('debian-files-list-in-source', $item->pointer)
+ if $item->size > 0;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/LineSeparators.pm b/lib/Lintian/Check/Debian/LineSeparators.pm
new file mode 100644
index 0000000..3c174ab
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LineSeparators.pm
@@ -0,0 +1,62 @@
+# debian/line-separators -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::LineSeparators;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# files in ./debian to check for line terminators
+my @CANDIDATES = qw(debian/control debian/changelog);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ if none { $item->name eq $_ } @CANDIDATES;
+
+ $self->pointed_hint('carriage-return-line-feed', $item->pointer)
+ if $item->bytes =~ m{\r\n\Z}m;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/LintianOverrides.pm b/lib/Lintian/Check/Debian/LintianOverrides.pm
new file mode 100644
index 0000000..448e7f9
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides.pm
@@ -0,0 +1,64 @@
+# debian/lintian-overrides -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::LintianOverrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $ppkg = quotemeta($self->processable->name);
+
+ # misplaced overrides
+ if ($item->name =~ m{^usr/share/doc/$ppkg/override\.[lL]intian(?:\.gz)?$}
+ || $item->name =~ m{^usr/share/lintian/overrides/$ppkg/.+}) {
+
+ $self->pointed_hint('override-file-in-wrong-location', $item->pointer);
+
+ } elsif ($item->name =~ m{^usr/share/lintian/overrides/(.+)/.+$}) {
+
+ my $expected = $1;
+
+ $self->pointed_hint('override-file-in-wrong-package',
+ $item->pointer, $expected)
+ unless $self->processable->name eq $expected;
+ }
+
+ $self->pointed_hint('old-source-override-location', $item->pointer)
+ if $item->name eq 'debian/source.lintian-overrides';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm b/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm
new file mode 100644
index 0000000..11c0077
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Comments.pm
@@ -0,0 +1,88 @@
+# debian/lintian-overrides/comments -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::LintianOverrides::Comments;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use POSIX qw(ENOENT);
+
+use Lintian::Spelling qw(check_spelling check_spelling_picky);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my @declared_overrides = @{$self->processable->overrides};
+
+ for my $override (@declared_overrides) {
+
+ next
+ unless length $override->justification;
+
+ my $tag_name = $override->tag_name;
+
+ # comments appear one or more lines before the override
+ # but they were concatenated
+ my $position = $override->position - 1;
+
+ my $pointer= $self->processable->override_file->pointer($position);
+
+ check_spelling(
+ $self->data,
+ $override->justification,
+ $self->group->spelling_exceptions,
+ $self->emitter('spelling-in-override-comment',$pointer, $tag_name)
+ );
+
+ check_spelling_picky(
+ $self->data,
+ $override->justification,
+ $self->emitter(
+ 'capitalization-in-override-comment',
+ $pointer,$tag_name
+ )
+ );
+ }
+
+ return;
+}
+
+sub emitter {
+ my ($self, @prefixed) = @_;
+
+ return sub {
+ return $self->pointed_hint(@prefixed, @_);
+ };
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm b/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm
new file mode 100644
index 0000000..e52d140
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm
@@ -0,0 +1,75 @@
+# debian/lintian-overrides/duplicate -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::LintianOverrides::Duplicate;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $SPACE => q{ };
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my %pattern_tracker;
+ for my $override (@{$self->processable->overrides}) {
+
+ my $pattern = $override->pattern;
+
+ # catch renames
+ my $tag_name = $self->profile->get_current_name($override->tag_name);
+
+ push(@{$pattern_tracker{$tag_name}{$pattern}}, $override);
+ }
+
+ for my $tag_name (keys %pattern_tracker) {
+ for my $pattern (keys %{$pattern_tracker{$tag_name}}) {
+
+ my @overrides = @{$pattern_tracker{$tag_name}{$pattern}};
+
+ my @same_context = map { $_->position } @overrides;
+ my $line_numbers = join($SPACE, (sort @same_context));
+
+ my $override_item = $self->processable->override_file;
+
+ $self->pointed_hint('duplicate-override-context',
+ $override_item->pointer,$tag_name,"(lines $line_numbers)")
+ if @overrides > 1;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm b/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm
new file mode 100644
index 0000000..3772889
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm
@@ -0,0 +1,52 @@
+# debian/lintian-overrides/malformed -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::LintianOverrides::Malformed;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ for my $error (@{$self->processable->override_errors}) {
+
+ my $message = $error->{message};
+ my $pointer = $error->{pointer};
+
+ $self->pointed_hint('malformed-override', $pointer, $message);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm b/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm
new file mode 100644
index 0000000..92e6125
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm
@@ -0,0 +1,65 @@
+# debian/lintian-overrides/mystery -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::LintianOverrides::Mystery;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $ARROW => q{=>};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ for my $override (@{$self->processable->overrides}) {
+
+ my $override_item = $self->processable->override_file;
+ my $pointer = $override_item->pointer($override->position);
+
+ my $mystery_name = $override->tag_name;
+ my $current_name = $self->profile->get_current_name($mystery_name);
+
+ $self->pointed_hint('alien-tag', $pointer, $mystery_name)
+ if !length $current_name;
+
+ $self->pointed_hint('renamed-tag', $pointer, $mystery_name, $ARROW,
+ $current_name)
+ if length $current_name
+ && $current_name ne $mystery_name;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm b/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm
new file mode 100644
index 0000000..cc2cda4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm
@@ -0,0 +1,80 @@
+# debian/lintian-overrides/restricted -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::LintianOverrides::Restricted;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(true);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ for my $override (@{$self->processable->overrides}) {
+
+ my $override_item = $self->processable->override_file;
+ my $pointer = $override_item->pointer($override->position);
+
+ my @architectures = @{$override->architectures};
+
+ if (@architectures && $self->processable->architecture eq 'all') {
+ $self->pointed_hint('invalid-override-restriction',
+ $pointer,'Architecture list in Arch:all installable');
+ next;
+ }
+
+ my @invalid
+ = grep { !$self->data->architectures->valid_restriction($_) }
+ @architectures;
+ $self->pointed_hint('invalid-override-restriction',
+ $pointer,"Unknown architecture wildcard $_")
+ for @invalid;
+
+ next
+ if @invalid;
+
+ # count negations
+ my $negations = true { /^!/ } @architectures;
+
+ # confirm it is either all or none
+ if ($negations > 0 && $negations != @architectures) {
+ $self->pointed_hint('invalid-override-restriction',
+ $pointer,'Inconsistent architecture negation');
+ next;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Maintscript.pm b/lib/Lintian/Check/Debian/Maintscript.pm
new file mode 100644
index 0000000..adee6be
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Maintscript.pm
@@ -0,0 +1,73 @@
+# debian/maintscript -- lintian check script -*- perl -*-
+
+# Copyright (C) 1999 by Joey Hess
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Maintscript;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->dirname eq 'debian/';
+
+ return
+ unless $item->basename =~ m{ (?: ^ | [.] ) maintscript $}x;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('maintscript-includes-maint-script-parameters',
+ $pointer)
+ if $line =~ /--\s+"\$(?:@|{@})"\s*$/;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/ManualPages.pm b/lib/Lintian/Check/Debian/ManualPages.pm
new file mode 100644
index 0000000..f1b654a
--- /dev/null
+++ b/lib/Lintian/Check/Debian/ManualPages.pm
@@ -0,0 +1,67 @@
+# debian/manual-pages -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::ManualPages;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw{none};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ if $self->processable->native;
+
+ my $debiandir = $self->processable->patched->resolve_path('debian');
+ return
+ unless $debiandir;
+
+ my @files = grep { $_->is_file } $debiandir->descendants;
+ my @nopatches = grep { $_->name !~ m{^debian/patches/} } @files;
+
+ my @manual_pages = grep { $_->basename =~ m{\.\d$} } @nopatches;
+
+ for my $item (@manual_pages) {
+
+ my $command = $item->basename;
+ $command =~ s/ [.] \d $//x;
+
+ $self->pointed_hint('maintainer-manual-page', $item->pointer)
+ if none { $command eq $_->basename } @files;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/NotInstalled.pm b/lib/Lintian/Check/Debian/NotInstalled.pm
new file mode 100644
index 0000000..6e787b4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/NotInstalled.pm
@@ -0,0 +1,74 @@
+# debian/not-installed -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::NotInstalled;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/not-installed';
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # disregard comments
+ next
+ if $line =~ m{^ \s* [#] }x;
+
+ # architecture triplet
+ $self->pointed_hint('unwanted-path-too-specific',
+ $item->pointer($position), $line)
+ if $line =~ m{^ usr/lib/ [^/-]+ - [^/-]+ - [^/-]+ / }x
+ && $line !~ m{^ usr/lib/ [*] / }x;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Patches.pm b/lib/Lintian/Check/Debian/Patches.pm
new file mode 100644
index 0000000..b9a3ec2
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches.pm
@@ -0,0 +1,104 @@
+# debian/patches -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2007 Marc Brockschmidt
+# Copyright (C) 2008 Raphael Hertzog
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Patches;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my @patch_system;
+
+ # Get build deps so we can decide which build system the
+ # maintainer meant to use:
+ my $build_deps = $self->processable->relation('Build-Depends-All');
+
+ # Get source package format
+ my $source_format = $self->processable->fields->value('Format');
+ my $quilt_format = ($source_format =~ /3\.\d+ \(quilt\)/) ? 1 : 0;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my $patch_dir = $debian_dir->resolve_path('patches');
+
+ # Find debian/patches/series, assuming debian/patches is a (symlink to a)
+ # dir. There are cases, where it is a file (ctwm: #778556)
+ my $patch_series;
+ $patch_series
+ = $self->processable->patched->resolve_path('debian/patches/series');
+
+ push(@patch_system, 'dpatch')
+ if $build_deps->satisfies('dpatch');
+
+ push(@patch_system, 'quilt')
+ if $quilt_format || $build_deps->satisfies('quilt');
+
+ $self->hint('patch-system', $_) for @patch_system;
+
+ $self->hint('more-than-one-patch-system')
+ if @patch_system > 1;
+
+ if (@patch_system && !$quilt_format) {
+
+ my $readme = $debian_dir->resolve_path('README.source');
+ $self->hint('patch-system-but-no-source-readme')
+ unless defined $readme;
+ }
+
+ my @direct_changes
+ = grep { !m{^debian/} } keys %{$self->processable->diffstat};
+ if (@direct_changes) {
+
+ my $files = $direct_changes[0];
+ $files .= " and $#direct_changes more"
+ if @direct_changes > 1;
+
+ $self->hint('patch-system-but-direct-changes-in-diff', $files)
+ if @patch_system;
+
+ $self->hint('direct-changes-in-diff-but-no-patch-system', $files)
+ unless @patch_system;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Patches/Count.pm b/lib/Lintian/Check/Debian/Patches/Count.pm
new file mode 100644
index 0000000..589e2ba
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Count.pm
@@ -0,0 +1,54 @@
+# debian/patches/count -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Patches::Count;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/patches/series';
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ # remove lines containing only comments
+ my @patches = grep { !/^\s*(?:#|$)/ } @lines;
+
+ $self->pointed_hint('number-of-patches', $item->pointer, scalar @patches);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Patches/Dep3.pm b/lib/Lintian/Check/Debian/Patches/Dep3.pm
new file mode 100644
index 0000000..6624a0c
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Dep3.pm
@@ -0,0 +1,105 @@
+# debian/patches/dep3 -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Patches::Dep3;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none);
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8);
+
+use Lintian::Deb822;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^debian/patches/};
+
+ return
+ unless $item->is_file;
+
+ return
+ if $item->name eq 'debian/patches/series'
+ || $item->name eq 'debian/patches/README';
+
+ my $bytes = $item->bytes;
+ return
+ unless length $bytes;
+
+ my ($headerbytes) = split(/^---/m, $bytes, 2);
+
+ return
+ unless valid_utf8($headerbytes);
+
+ my $header = decode_utf8($headerbytes);
+ return
+ unless length $header;
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->parse_string($header);
+
+ } catch {
+ return;
+ }
+
+ return
+ unless @sections;
+
+ # use last mention when present multiple times
+ my $origin = $deb822->last_mention('Origin');
+
+ my ($category) = split(m{\s*,\s*}, $origin, 2);
+ $category //= $EMPTY;
+ return
+ if any { $category eq $_ } qw(upstream backport);
+
+ $self->pointed_hint('patch-not-forwarded-upstream', $item->pointer)
+ if $deb822->last_mention('Forwarded') eq 'no'
+ || none { length } (
+ $deb822->last_mention('Applied-Upstream'),
+ $deb822->last_mention('Bug'),
+ $deb822->last_mention('Forwarded')
+ );
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Patches/Dpatch.pm b/lib/Lintian/Check/Debian/Patches/Dpatch.pm
new file mode 100644
index 0000000..337fa53
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Dpatch.pm
@@ -0,0 +1,150 @@
+# debian/patches -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2007 Marc Brockschmidt
+# Copyright (C) 2008 Raphael Hertzog
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Patches::Dpatch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+sub source {
+ my ($self) = @_;
+
+ my $build_deps = $self->processable->relation('Build-Depends-All');
+ return
+ unless $build_deps->satisfies('dpatch');
+
+ my $patch_dir
+ = $self->processable->patched->resolve_path('debian/patches/');
+ return
+ unless defined $patch_dir;
+
+ $self->hint('package-uses-deprecated-dpatch-patch-system');
+
+ my @list_files
+ = grep {$_->basename =~ m/^00list/ && $_->is_open_ok}
+ $patch_dir->children;
+
+ $self->hint('dpatch-build-dep-but-no-patch-list')
+ unless @list_files;
+
+ my $options_file = $patch_dir->resolve_path('00options');
+
+ my $list_uses_cpp = 0;
+ $list_uses_cpp = 1
+ if defined $options_file
+ && $options_file->decoded_utf8 =~ /DPATCH_OPTION_CPP=1/;
+
+ for my $file (@list_files) {
+ my @patches;
+
+ open(my $fd, '<', $file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $file->unpacked_path);
+
+ while(my $line = <$fd>) {
+ chomp $line;
+
+ #ignore comments or CPP directive
+ next
+ if $line =~ /^\#/;
+
+ # remove C++ style comments
+ $line =~ s{//.*}{}
+ if $list_uses_cpp;
+
+ if ($list_uses_cpp && $line =~ m{/\*}) {
+
+ # remove C style comments
+ $line .= <$fd> while ($line !~ m{\*/});
+
+ $line =~ s{/\*[^*]*\*/}{}g;
+ }
+
+ #ignore blank lines
+ next
+ if $line =~ /^\s*$/;
+
+ push @patches, split($SPACE, $line);
+ }
+ close($fd);
+
+ for my $patch_name (@patches) {
+
+ my $patch_file = $patch_dir->child($patch_name);
+ $patch_file = $patch_dir->child("${patch_name}.dpatch")
+ unless defined $patch_file;
+
+ unless (defined $patch_file) {
+ $self->hint('dpatch-index-references-non-existent-patch',
+ $patch_name);
+ next;
+ }
+
+ next
+ unless $patch_file->is_open_ok;
+
+ my $description = $EMPTY;
+ open(my $fd, '<', $patch_file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $patch_file->unpacked_path);
+
+ while (my $line = <$fd>) {
+ # stop if something looking like a patch
+ # starts:
+ last
+ if $line =~ /^---/;
+ # note comment if we find a proper one
+ $description .= $1
+ if $line =~ /^\#+\s*DP:\s*(\S.*)$/
+ && $1 !~ /^no description\.?$/i;
+ $description .= $1
+ if $line =~ /^\# (?:Description|Subject): (.*)/;
+ }
+ close($fd);
+
+ $self->pointed_hint('dpatch-missing-description',
+ $patch_file->pointer)
+ unless length $description;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Patches/Quilt.pm b/lib/Lintian/Check/Debian/Patches/Quilt.pm
new file mode 100644
index 0000000..2e78055
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Patches/Quilt.pm
@@ -0,0 +1,290 @@
+# debian/patches/quilt -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2007 Marc Brockschmidt
+# Copyright (C) 2008 Raphael Hertzog
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Patches::Quilt;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(decode_utf8 encode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $PATCH_DESC_TEMPLATE =>
+ 'TODO: Put a short summary on the line above and replace this paragraph';
+const my $EMPTY => q{};
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $item, @orig_args) = @_;
+
+ my $pointer = $item->pointer($.);
+
+ return sub {
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+sub source {
+ my ($self) = @_;
+
+ my $build_deps = $self->processable->relation('Build-Depends-All');
+
+ my $source_format = $self->processable->fields->value('Format');
+ my $quilt_format = ($source_format =~ /3\.\d+ \(quilt\)/) ? 1 : 0;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian/');
+ return
+ unless defined $debian_dir;
+
+ my $patch_dir = $debian_dir->resolve_path('patches');
+ my %known_files;
+
+ # Find debian/patches/series, assuming debian/patches is a (symlink to a)
+ # dir. There are cases, where it is a file (ctwm: #778556)
+ my $patch_series;
+ $patch_series
+ = $self->processable->patched->resolve_path('debian/patches/series');
+
+ # 3.0 (quilt) sources do not need quilt
+ unless ($quilt_format) {
+
+ $self->hint('quilt-build-dep-but-no-series-file')
+ if $build_deps->satisfies('quilt')
+ && (!defined $patch_series || !$patch_series->is_open_ok);
+
+ $self->pointed_hint('quilt-series-but-no-build-dep',
+ $patch_series->pointer)
+ if $patch_series
+ && $patch_series->is_file
+ && !$build_deps->satisfies('quilt');
+ }
+
+ return
+ unless $quilt_format || $build_deps->satisfies('quilt');
+
+ if ($patch_series && $patch_series->is_open_ok) {
+
+ my @patch_names;
+
+ open(my $series_fd, '<', $patch_series->unpacked_path)
+ or die encode_utf8('Cannot open ' . $patch_series->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$series_fd>) {
+
+ # Strip comment
+ $line =~ s/(?:^|\s+)#.*$//;
+
+ if (rindex($line,"\n") < 0) {
+ $self->pointed_hint('quilt-series-without-trailing-newline',
+ $patch_series->pointer);
+ }
+
+ # trim both ends
+ $line =~ s/^\s+|\s+$//g;
+
+ next
+ unless length $line;
+
+ if ($line =~ m{^(\S+)\s+(\S.*)$}) {
+
+ my $patch = $1;
+ my $patch_options = $2;
+
+ push(@patch_names, $patch);
+
+ $self->pointed_hint('quilt-patch-with-non-standard-options',
+ $patch_series->pointer($position), $line)
+ unless $patch_options eq '-p1';
+
+ } else {
+ push(@patch_names, $line);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $series_fd;
+
+ my @patch_files;
+ for my $name (@patch_names) {
+
+ my $item = $patch_dir->resolve_path($name);
+
+ if (defined $item && $item->is_file) {
+ push(@patch_files, $item);
+
+ } else {
+ $self->pointed_hint(
+ 'quilt-series-references-non-existent-patch',
+ $patch_series->pointer, $name);
+ }
+ }
+
+ for my $item (@patch_files) {
+
+ next
+ unless $item->is_open_ok;
+
+ my $description = $EMPTY;
+ my $has_template_description = 0;
+
+ open(my $patch_fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$patch_fd>) {
+
+ # stop if something looking like a patch starts:
+ last
+ if $line =~ /^---/;
+
+ next
+ if $line =~ /^\s*$/;
+
+ # Skip common "lead-in" lines
+ $description .= $line
+ unless $line =~ m{^(?:Index: |=+$|diff .+|index |From: )};
+
+ $has_template_description = 1
+ if $line =~ / \Q$PATCH_DESC_TEMPLATE\E /msx;
+ }
+ close $patch_fd;
+
+ $self->pointed_hint('quilt-patch-missing-description',
+ $item->pointer)
+ unless length $description;
+
+ $self->pointed_hint('quilt-patch-using-template-description',
+ $item->pointer)
+ if $has_template_description;
+
+ $self->check_patch($item, $description);
+ }
+ }
+
+ if ($quilt_format) { # 3.0 (quilt) specific checks
+ # Format 3.0 packages may generate a debian-changes-$version patch
+ my $version = $self->processable->fields->value('Version');
+ my $patch_header= $debian_dir->resolve_path('source/patch-header');
+ my $versioned_patch;
+
+ $versioned_patch= $patch_dir->resolve_path("debian-changes-$version")
+ if $patch_dir;
+
+ if (defined $versioned_patch && $versioned_patch->is_file) {
+
+ $self->pointed_hint('format-3.0-but-debian-changes-patch',
+ $versioned_patch->pointer)
+ if !defined $patch_header || !$patch_header->is_file;
+ }
+ }
+
+ if ($patch_dir and $patch_dir->is_dir and $source_format ne '2.0') {
+ # Check all series files, including $vendor.series
+ for my $item ($patch_dir->children) {
+ next
+ unless $item->name =~ /\/(.+\.)?series$/;
+ next
+ unless $item->is_open_ok;
+
+ $known_files{$item->basename}++;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$fd>) {
+ $known_files{$1}++
+ if $line =~ m{^\s*(?:#+\s*)?(\S+)};
+ }
+ close($fd);
+
+ $self->pointed_hint('package-uses-vendor-specific-patch-series',
+ $item->pointer)
+ if $item->name =~ m{ [.]series $}x;
+ }
+
+ for my $item ($patch_dir->descendants) {
+ next
+ if $item->basename =~ /^README(\.patches)?$/
+ || $item->basename =~ /\.in/g;
+
+ # Use path relative to debian/patches for "subdir/foo"
+ my $name = substr($item, length $patch_dir);
+
+ $self->pointed_hint(
+ 'patch-file-present-but-not-mentioned-in-series',
+ $item->pointer)
+ unless $known_files{$name} || $item->is_dir;
+ }
+ }
+
+ return;
+}
+
+# Checks on patches common to all build systems.
+sub check_patch {
+ my ($self, $item, $description) = @_;
+
+ unless (any { /(spelling|typo)/i } ($item->name, $description)) {
+ my $tag_emitter
+ = $self->spelling_tag_emitter('spelling-error-in-patch-description',
+ $item);
+ check_spelling($self->data, $description,
+ $self->group->spelling_exceptions,
+ $tag_emitter, 0);
+ }
+
+ # Use --strip=1 to strip off the first layer of directory in case
+ # the parent directory in which the patches were generated was
+ # named "debian". This will produce false negatives for --strip=0
+ # patches that modify files in the debian/* directory, but as of
+ # 2010-01-01, all cases where the first level of the patch path is
+ # "debian/" in the archive are false positives.
+ my $bytes = safe_qx('lsdiff', '--strip=1', $item->unpacked_path);
+ my $output = decode_utf8($bytes);
+
+ my @debian_files = ($output =~ m{^((?:\./)?debian/.*)$}ms);
+
+ $self->pointed_hint('patch-modifying-debian-files', $item->pointer, $_)
+ for @debian_files;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/PoDebconf.pm b/lib/Lintian/Check/Debian/PoDebconf.pm
new file mode 100644
index 0000000..333fee5
--- /dev/null
+++ b/lib/Lintian/Check/Debian/PoDebconf.pm
@@ -0,0 +1,391 @@
+# debian/po-debconf -- lintian check script -*- perl -*-
+
+# Copyright (C) 2002-2004 by Denis Barbier <barbier@linuxfr.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::PoDebconf;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd qw(realpath);
+use File::Temp();
+use IPC::Run3;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ my $has_template = 0;
+ my @lang_templates;
+ my $full_translation = 0;
+
+ my $debian_dir = $processable->patched->resolve_path('debian/');
+ return
+ unless $debian_dir;
+
+ my $debian_po_dir = $debian_dir->resolve_path('po');
+ my ($templ_pot_path, $potfiles_in_path);
+
+ if ($debian_po_dir and $debian_po_dir->is_dir) {
+ $templ_pot_path = $debian_po_dir->resolve_path('templates.pot');
+ $potfiles_in_path = $debian_po_dir->resolve_path('POTFILES.in');
+ }
+
+ # First, check whether this package seems to use debconf but not
+ # po-debconf. Read the templates file and look at the template
+ # names it provides, since some shared templates aren't
+ # translated.
+ for my $item ($debian_dir->children) {
+ next
+ unless $item->is_open_ok;
+
+ if ($item->basename =~ m/^(.+\.)?templates(\..+)?$/) {
+ if ($item->basename =~ m/templates\.\w\w(_\w\w)?$/) {
+ push(@lang_templates, $item);
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$fd>) {
+
+ $self->pointed_hint('untranslatable-debconf-templates',
+ $item->pointer($.))
+ if $line =~ /^Description: (.+)/i
+ && $1 !~/for internal use/;
+ }
+
+ close $fd;
+
+ } else {
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $in_template = 0;
+ my $saw_tl_note = 0;
+ while (my $line = <$fd>) {
+ chomp $line;
+
+ $self->pointed_hint('translated-default-field',
+ $item->pointer($.))
+ if $line =~ m{^_Default(?:Choice)?: [^\[]*$}
+ && !$saw_tl_note;
+
+ $self->pointed_hint('untranslatable-debconf-templates',
+ $item->pointer($.))
+ if $line =~ /^Description: (.+)/i
+ && $1 !~/for internal use/;
+
+ if ($line =~ /^#/) {
+ # Is this a comment for the translators?
+ $saw_tl_note = 1
+ if $line =~ /translators/i;
+
+ next;
+ }
+
+ # If it is not a continuous comment immediately before the
+ # _Default(Choice) field, we don't care about it.
+ $saw_tl_note = 0;
+
+ if ($line =~ /^Template: (\S+)/i) {
+ my $template = $1;
+ next
+ if $template eq 'shared/packages-wordlist'
+ or $template eq 'shared/packages-ispell';
+
+ next
+ if $template =~ m{/languages$};
+
+ $in_template = 1;
+
+ } elsif ($in_template && $line =~ /^_?Description: (.+)/i){
+ my $description = $1;
+ next
+ if $description =~ /for internal use/;
+ $has_template = 1;
+
+ } elsif ($in_template && !length($line)) {
+ $in_template = 0;
+ }
+ }
+
+ close($fd);
+ }
+ }
+ }
+
+ #TODO: check whether all templates are named in TEMPLATES.pot
+ if ($has_template) {
+ if (not $debian_po_dir or not $debian_po_dir->is_dir) {
+ $self->hint('not-using-po-debconf');
+ return;
+ }
+ } else {
+ return;
+ }
+
+ # If we got here, we're using po-debconf, so there shouldn't be any stray
+ # language templates left over from debconf-mergetemplate.
+ for my $item (@lang_templates) {
+ $self->pointed_hint('stray-translated-debconf-templates',
+ $item->pointer)
+ unless $item->basename =~ m{ templates[.]in$}x;
+ }
+
+ my $missing_files = 0;
+
+ if ($potfiles_in_path and $potfiles_in_path->is_open_ok) {
+
+ open(my $fd, '<', $potfiles_in_path->unpacked_path)
+ or
+ die encode_utf8('Cannot open ' . $potfiles_in_path->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+ chomp $line;
+
+ next
+ if $line =~ /^\s*\#/;
+
+ $line =~ s/.*\]\s*//;
+
+ # Cannot check files which are not under debian/
+ # m,^\.\./, or
+ next
+ if $line eq $EMPTY;
+
+ my $pointer = $potfiles_in_path->pointer($position);
+
+ my $po_path = $debian_dir->resolve_path($line);
+ unless ($po_path and $po_path->is_file) {
+
+ $self->pointed_hint('missing-file-from-potfiles-in',
+ $pointer, $line);
+ $missing_files = 1;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ } else {
+ $self->hint('missing-potfiles-in');
+ $missing_files = 1;
+ }
+ if (not $templ_pot_path or not $templ_pot_path->is_open_ok) {
+ # We use is_open_ok here, because if it is present, we will
+ # (have a subprocess) open it if the POTFILES.in file also
+ # existed.
+ $self->hint('missing-templates-pot');
+ $missing_files = 1;
+ }
+
+ if ($missing_files == 0) {
+ my $temp_obj
+ = File::Temp->newdir('lintian-po-debconf-XXXXXX',TMPDIR => 1);
+ my $abs_tempdir = realpath($temp_obj->dirname)
+ or croak('Cannot resolve ' . $temp_obj->dirname . ": $!");
+ # We need an extra level of dirs, as intltool (in)directly
+ # tries to use files in ".." if they exist
+ # (e.g. ../templates.h).
+ # - In fact, we also need to copy debian/templates into
+ # this "fake package directory", since intltool-updates
+ # sometimes want to write files to "../templates" based
+ # on the contents of the package. (See #778558)
+ my $tempdir = "$abs_tempdir/po";
+ my $test_pot = "$tempdir/test.pot";
+ my $tempdir_templates = "${abs_tempdir}/templates";
+ my $d_templates = $debian_dir->resolve_path('templates');
+
+ # Create our extra level
+ mkdir($tempdir)
+ or die encode_utf8('Cannot create directory ' . $tempdir);
+
+ # Copy the templates dir because intltool-update might
+ # write to it.
+ safe_qx(
+ qw{cp -a --reflink=auto --},
+ $d_templates->unpacked_path,
+ $tempdir_templates
+ )if $d_templates;
+
+ my $error;
+ my %save = %ENV;
+ my $cwd = Cwd::getcwd;
+
+ try {
+ $ENV{INTLTOOL_EXTRACT}
+ = '/usr/share/intltool-debian/intltool-extract';
+ # use of $debian_po is safe; we accessed two children by now.
+ $ENV{srcdir} = $debian_po_dir->unpacked_path;
+
+ chdir($tempdir)
+ or die encode_utf8('Cannot change directory ' . $tempdir);
+
+ # generate a "test.pot" in a tempdir
+ my @intltool = (
+ '/usr/share/intltool-debian/intltool-update',
+ '--gettext-package=test','--pot'
+ );
+ safe_qx(@intltool);
+ die encode_utf8("system @intltool failed: $?")
+ if $?;
+
+ } catch {
+ # catch any error
+ $error = $@;
+
+ } finally {
+ # restore environment
+ %ENV = %save;
+
+ # restore working directory
+ chdir($cwd)
+ or die encode_utf8('Cannot change directory ' . $cwd);
+ }
+
+ # output could be helpful to user but is currently not printed
+
+ if ($error) {
+ $self->pointed_hint('invalid-potfiles-in',
+ $potfiles_in_path->pointer);
+ return;
+ }
+
+ # throw away output on the following commands
+ $error = undef;
+
+ try {
+ # compare our "test.pot" with the existing "templates.pot"
+ my @testleft = (
+ 'msgcmp', '--use-untranslated',
+ $test_pot, $templ_pot_path->unpacked_path
+ );
+ safe_qx(@testleft);
+ die encode_utf8("system @testleft failed: $?")
+ if $?;
+
+ # is this not equivalent to the previous command? - FL
+ my @testright = (
+ 'msgcmp', '--use-untranslated',
+ $templ_pot_path->unpacked_path, $test_pot
+ );
+ safe_qx(@testright);
+ die encode_utf8("system @testright failed: $?")
+ if $?;
+
+ } catch {
+ # catch any error
+ $error = $@;
+ }
+
+ $self->pointed_hint('newer-debconf-templates',$templ_pot_path->pointer)
+ if length $error;
+ }
+
+ return
+ unless $debian_po_dir;
+
+ for my $po_item ($debian_po_dir->children) {
+
+ next
+ unless $po_item->basename =~ m/\.po$/ || $po_item->is_dir;
+
+ $self->pointed_hint('misnamed-po-file', $po_item->pointer)
+ unless (
+ $po_item->basename =~ /^[a-z]{2,3}(_[A-Z]{2})?(?:\@[^\.]+)?\.po$/);
+
+ next
+ unless $po_item->is_open_ok;
+
+ my $bytes = $po_item->bytes;
+
+ $self->pointed_hint('debconf-translation-using-general-list',
+ $po_item->pointer)
+ if $bytes =~ /Language\-Team:.*debian-i18n\@lists\.debian\.org/i;
+
+ unless ($bytes =~ /^msgstr/m) {
+
+ $self->pointed_hint('invalid-po-file', $po_item->pointer);
+ next;
+ }
+
+ if ($bytes =~ /charset=(.*?)\\n/) {
+
+ my $charset = ($1 eq 'CHARSET' ? $EMPTY : $1);
+
+ $self->pointed_hint('unknown-encoding-in-po-file',
+ $po_item->pointer)
+ unless length $charset;
+ }
+
+ my $error;
+
+ my $stats;
+
+ delete local $ENV{$_}
+ for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV;
+ local $ENV{LC_ALL} = 'C';
+
+ my @command = (
+ 'msgfmt', '-o', '/dev/null', '--statistics',
+ $po_item->unpacked_path
+ );
+
+ run3(\@command, \undef, \undef, \$stats);
+
+ $self->pointed_hint('invalid-po-file', $po_item->pointer)
+ if $?;
+
+ $stats //= $EMPTY;
+
+ $full_translation = 1
+ if $stats =~ m/^\w+ \w+ \w+\.$/;
+ }
+
+ $self->hint('no-complete-debconf-translation')
+ if !$full_translation;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Readme.pm b/lib/Lintian/Check/Debian/Readme.pm
new file mode 100644
index 0000000..c8fd030
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Readme.pm
@@ -0,0 +1,176 @@
+# debian/readme -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Readme;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $VERTICAL_BAR => q{|};
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $item, @orig_args) = @_;
+
+ my $pointer = $item->pointer($.);
+
+ return sub {
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+sub open_readme {
+ my ($pkg_name, $processable) = @_;
+
+ my $doc_dir
+ = $processable->installed->resolve_path("usr/share/doc/${pkg_name}/");
+
+ if (defined $doc_dir) {
+
+ for my $name (
+ qw(README.Debian.gz README.Debian README.debian.gz README.debian)){
+
+ my $path = $doc_dir->child($name);
+
+ next
+ unless $path && $path->is_open_ok;
+
+ if ($name =~ m/\.gz$/) {
+ open(my $fd, '<:gzip', $path->unpacked_path)
+ or die encode_utf8('Cannot open ' . $path->unpacked_path);
+
+ return $fd;
+ }
+
+ open(my $fd, '<', $path->unpacked_path)
+ or die encode_utf8('Cannot open ' . $path->unpacked_path);
+
+ return $fd;
+ }
+ }
+
+ return undef;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg_name = $self->processable->name;
+ my $group = $self->group;
+
+ my $doc_dir
+ = $self->processable->installed->resolve_path(
+ "usr/share/doc/${pkg_name}/");
+
+ return
+ unless defined $doc_dir;
+
+ my $item;
+ my $fd;
+
+ for my $name (
+ qw(README.Debian.gz README.Debian README.debian.gz README.debian)){
+
+ $item = $doc_dir->child($name);
+
+ next
+ unless $item && $item->is_open_ok;
+
+ if ($name =~ m/\.gz$/) {
+ open($fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ last;
+ }
+
+ open($fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ last;
+ }
+
+ return
+ unless defined $item
+ && defined $fd;
+
+ my $readme = $EMPTY;
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('readme-debian-mentions-usr-doc', $pointer)
+ if $line =~ m{ /usr/doc \b }x;
+
+ $readme .= $line;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ my @template =(
+ 'Comments regarding the Package',
+ 'So far nothing to say',
+ '<possible notes regarding this package - if none, delete this file>',
+ 'Automatically generated by debmake'
+ );
+
+ my $regex = join($VERTICAL_BAR, @template);
+
+ if ($readme =~ m/$regex/i) {
+ $self->pointed_hint('readme-debian-contains-debmake-template',
+ $item->pointer);
+
+ } elsif ($readme =~ m/^\s*-- [^<]*<([^> ]+.\@[^>.]*)>/m) {
+
+ my $address = $1;
+
+ $self->pointed_hint('readme-debian-contains-invalid-email-address',
+ $item->pointer, $address);
+ }
+
+ check_spelling($self->data,$readme,$group->spelling_exceptions,
+ $self->spelling_tag_emitter('spelling-error-in-readme-debian', $item));
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Rules.pm b/lib/Lintian/Check/Debian/Rules.pm
new file mode 100644
index 0000000..ffae6cb
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Rules.pm
@@ -0,0 +1,671 @@
+# debian/rules -- lintian check script -*- perl -*-
+
+# Copyright (C) 2006 Russ Allbery <rra@debian.org>
+# Copyright (C) 2005 Rene van Bevern <rvb@pro-linux.de>
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+package Lintian::Check::Debian::Rules;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any none uniq);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $PERCENT => q{%};
+
+my @py3versions = qw(3.4 3.5 3.6 3.7);
+
+my $PYTHON_DEPEND= 'python2:any | python2-dev:any';
+my $PYTHON3_DEPEND
+ = 'python3:any | python3-dev:any | python3-all:any | python3-all-dev:any';
+my $PYTHON2X_DEPEND = 'python2.7:any | python2.7-dev:any';
+my $PYTHON3X_DEPEND
+ = join(' | ',map { "python${_}:any | python${_}-dev:any" } @py3versions);
+my $ANYPYTHON_DEPEND
+ = "$PYTHON_DEPEND | $PYTHON2X_DEPEND | $PYTHON3_DEPEND | $PYTHON3X_DEPEND";
+my $PYTHON3_ALL_DEPEND
+ = 'python3-all:any | python3-all-dev:any | python3-all-dbg:any';
+
+my %TAG_FOR_POLICY_TARGET = (
+ build => 'debian-rules-missing-required-target',
+ binary => 'debian-rules-missing-required-target',
+ 'binary-arch' => 'debian-rules-missing-required-target',
+ 'binary-indep' => 'debian-rules-missing-required-target',
+ clean => 'debian-rules-missing-required-target',
+ 'build-arch' => 'debian-rules-missing-required-target',
+ 'build-indep' => 'debian-rules-missing-required-target'
+);
+
+# Rules about required debhelper command ordering. Each command is put into a
+# class and the tag is issued if they're called in the wrong order for the
+# classes. Unknown commands won't trigger this flag.
+my %debhelper_order = (
+ dh_makeshlibs => 1,
+ dh_shlibdeps => 2,
+ dh_installdeb => 2,
+ dh_gencontrol => 2,
+ dh_builddeb => 3
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_dir = $self->processable->patched->resolve_path('debian');
+
+ my $rules;
+ $rules = $debian_dir->child('rules')
+ if defined $debian_dir;
+
+ return
+ unless defined $rules;
+
+ # Policy could be read as allowing debian/rules to be a symlink to
+ # some other file, and in a native Debian package it could be a
+ # symlink to a file that we didn't unpack.
+ $self->pointed_hint('debian-rules-is-symlink', $rules->pointer)
+ if $rules->is_symlink;
+
+ # dereference symbolic links
+ $rules = $rules->follow;
+
+ return
+ unless defined $rules;
+
+ $self->pointed_hint('debian-rules-not-executable', $rules->pointer)
+ unless $rules->is_executable;
+
+ my $KNOWN_MAKEFILES= $self->data->load('rules/known-makefiles', '\|\|');
+ my $DEPRECATED_MAKEFILES= $self->data->load('rules/deprecated-makefiles');
+
+ my $architecture = $self->processable->fields->value('Architecture');
+
+ # If the version field is missing, we assume a neutral non-native one.
+ my $version = $self->processable->fields->value('Version') || '0-1';
+
+ # Check for required #!/usr/bin/make -f opening line. Allow -r or -e; a
+ # strict reading of Policy doesn't allow either, but they seem harmless.
+ $self->pointed_hint('debian-rules-not-a-makefile', $rules->pointer)
+ unless $rules->hashbang =~ m{^/usr/bin/make\s+-[re]?f[re]?$};
+
+ # Certain build tools must be listed in Build-Depends even if there are no
+ # arch-specific packages because they're required in order to run the clean
+ # rule. (See Policy 7.6.) The following is a list of package dependencies;
+ # regular expressions that, if they match anywhere in the debian/rules file,
+ # say that this package is allowed (and required) in Build-Depends; and
+ # optional tags to use for reporting the problem if some information other
+ # than the default is required.
+ my %GLOBAL_CLEAN_DEPENDS = (
+ 'ant:any' => [qr{^include\s*/usr/share/cdbs/1/rules/ant\.mk}],
+ 'cdbs:any' => [
+ qr{^include\s+/usr/share/cdbs/},
+ qr{^include\s+/usr/share/R/debian/r-cran\.mk}
+ ],
+ 'dbs:any' => [qr{^include\s+/usr/share/dbs/}],
+ 'dh-make-php:any' => [qr{^include\s+/usr/share/cdbs/1/class/pear\.mk}],
+ 'debhelper:any | debhelper-compat:any' =>[
+ qr{^include\s+/usr/share/cdbs/1/rules/debhelper\.mk},
+ qr{^include\s+/usr/share/R/debian/r-cran\.mk}
+ ],
+ 'dpatch:any' => [
+ qr{^include\s+/usr/share/dpatch/},
+ qr{^include\s+/usr/share/cdbs/1/rules/dpatch\.mk}
+ ],
+ 'gnome-pkg-tools:any | dh-sequence-gnome:any' =>
+ [qr{^include\s+/usr/share/gnome-pkg-tools/}],
+ 'quilt:any' => [
+ qr{^include\s+/usr/share/quilt/},
+ qr{^include\s+/usr/share/cdbs/1/rules/patchsys-quilt\.mk}
+ ],
+ 'mozilla-devscripts:any' =>
+ [qr{^include\s+/usr/share/mozilla-devscripts/}],
+ 'ruby-pkg-tools:any' =>
+ [qr{^include\s+/usr/share/ruby-pkg-tools/1/class/}],
+ 'r-base-dev:any' => [qr{^include\s+/usr/share/R/debian/r-cran\.mk}],
+ $ANYPYTHON_DEPEND =>[qr{/usr/share/cdbs/1/class/python-distutils\.mk}],
+ );
+
+ # A list of packages; regular expressions that, if they match anywhere in the
+ # debian/rules file, this package must be listed in either Build-Depends or
+ # Build-Depends-Indep as appropriate; and optional tags as above.
+ my %GLOBAL_DEPENDS = (
+ 'dh-ocaml:any, ocaml-nox:any | ocaml:any' =>
+ [qr/^\t\s*dh_ocaml(?:init|doc)\s/],
+ 'debhelper:any | debhelper-compat:any | dh-autoreconf:any' =>
+ [qr/^\t\s*dh_autoreconf(?:_clean)?\s/],
+ );
+
+ # Similarly, this list of packages, regexes, and optional tags say that if the
+ # regex matches in one of clean, build-arch, binary-arch, or a rule they
+ # depend on, this package is allowed (and required) in Build-Depends.
+ my %RULE_CLEAN_DEPENDS =(
+ 'ant:any' => [qr/^\t\s*(\S+=\S+\s+)*ant\s/],
+ 'debhelper:any | debhelper-compat:any' =>
+ [qr/^\t\s*dh_(?!autoreconf).+/],
+ 'dh-ocaml:any, ocaml-nox:any | ocaml:any' =>[qr/^\t\s*dh_ocamlinit\s/],
+ 'dpatch:any' => [qr/^\t\s*(\S+=\S+\s+)*dpatch\s/],
+ 'po-debconf:any' => [qr/^\t\s*debconf-updatepo\s/],
+ $PYTHON_DEPEND => [qr/^\t\s*python\s/],
+ $PYTHON3_DEPEND => [qr/^\t\s*python3\s/],
+ $ANYPYTHON_DEPEND => [qr/\ssetup\.py\b/],
+ 'quilt:any' => [qr/^\t\s*(\S+=\S+\s+)*quilt\s/],
+ );
+
+ my $build_all = $self->processable->relation('Build-Depends-All');
+ my $build_all_norestriction
+ = $self->processable->relation_norestriction('Build-Depends-All');
+ my $build_regular = $self->processable->relation('Build-Depends');
+ my $build_indep = $self->processable->relation('Build-Depends-Indep');
+
+ # no need to look for items we have
+ delete %GLOBAL_DEPENDS{$_}
+ for grep { $build_regular->satisfies($_) } keys %GLOBAL_DEPENDS;
+ delete %GLOBAL_CLEAN_DEPENDS{$_}
+ for grep { $build_regular->satisfies($_) } keys %GLOBAL_CLEAN_DEPENDS;
+ delete %RULE_CLEAN_DEPENDS{$_}
+ for grep { $build_regular->satisfies($_) } keys %RULE_CLEAN_DEPENDS;
+
+ my @needed;
+ my @needed_clean;
+
+ # Scan debian/rules. We would really like to let make do this for
+ # us, but unfortunately there doesn't seem to be a way to get make
+ # to syntax-check and analyze a makefile without running at least
+ # $(shell) commands.
+ #
+ # We skip some of the rule analysis if debian/rules includes any
+ # other files, since to chase all includes we'd have to have all
+ # of its build dependencies installed.
+ local $_ = undef;
+
+ my @arch_rules = map { qr/^$_$/ } qw(clean binary-arch build-arch);
+ my @indep_rules = qw(build build-indep binary-indep);
+ my @current_targets;
+ my %rules_per_target;
+ my %debhelper_group;
+ my %seen;
+ my %overridden;
+ my $maybe_skipping;
+ my @conditionals;
+ my %variables;
+ my $includes = 0;
+
+ my $contents = $rules->decoded_utf8;
+ return
+ unless length $contents;
+
+ my @lines = split(/\n/, $contents);
+
+ my $continued = $EMPTY;
+ my $position = 1;
+
+ for my $line (@lines) {
+
+ my $pointer = $rules->pointer($position);
+
+ $self->pointed_hint('debian-rules-is-dh_make-template', $pointer)
+ if $line =~ m/dh_make generated override targets/;
+
+ next
+ if $line =~ /^\s*\#/;
+
+ if (length $continued) {
+ $line = $continued . $line;
+ $continued = $EMPTY;
+ }
+
+ if ($line =~ s/\\$//) {
+ $continued = $line;
+ next;
+ }
+
+ if ($line =~ /^\s*[s-]?include\s+(\S++)/){
+ my $makefile = $1;
+ my $targets = $KNOWN_MAKEFILES->value($makefile);
+ if (defined $targets){
+ for my $target (split /\s*+,\s*+/, $targets){
+ $seen{$target}++ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+ } else {
+ $includes = 1;
+ }
+
+ $self->pointed_hint('debian-rules-uses-deprecated-makefile',
+ $pointer, $makefile)
+ if $DEPRECATED_MAKEFILES->recognizes($makefile);
+ }
+
+ # problems occurring only outside targets
+ unless (%seen) {
+
+ # Check for DH_COMPAT settings outside of any rule, which are now
+ # deprecated. It's a bit easier structurally to do this here than in
+ # debhelper.
+ $self->pointed_hint('debian-rules-sets-DH_COMPAT', $pointer)
+ if $line =~ /^\s*(?:export\s+)?DH_COMPAT\s*:?=/;
+
+ $self->pointed_hint('debian-rules-sets-DEB_BUILD_OPTIONS',$pointer)
+ if $line =~ /^\s*(?:export\s+)?DEB_BUILD_OPTIONS\s*:?=/;
+
+ if (
+ $line =~m{^
+ \s*(?:export\s+)?
+ (DEB_(?:HOST|BUILD|TARGET)_(?:ARCH|MULTIARCH|GNU)[A-Z_]*)\s*:?=
+ }x
+ ) {
+ my $variable = $1;
+
+ $self->pointed_hint(
+ 'debian-rules-sets-dpkg-architecture-variable',
+ $pointer, $variable);
+ }
+
+ }
+
+ if ( $line =~ /^\t\s*-(?:\$[\(\{]MAKE[\}\)]|make)\s.*(?:dist)?clean/s
+ || $line
+ =~ /^\t\s*(?:\$[\(\{]MAKE[\}\)]|make)\s(?:.*\s)?-(\w*)i.*(?:dist)?clean/s
+ ) {
+ my $flags = $1 // $EMPTY;
+
+ # Ignore "-C<dir>" (#671537)
+ $self->pointed_hint('debian-rules-ignores-make-clean-error',
+ $pointer)
+ unless $flags =~ /^C/;
+ }
+
+ if ($line
+ =~ m{dh_strip\b.*(--(?:ddeb|dbgsym)-migration=(?:'[^']*'|\S*))}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('debug-symbol-migration-possibly-complete',
+ $pointer, $context);
+ }
+
+ $self->pointed_hint('debian-rules-passes-version-info-to-dh_shlibdeps',
+ $pointer)
+ if $line =~ m{dh_shlibdeps\b.*(?:--version-info|-V)\b};
+
+ $self->pointed_hint('debian-rules-updates-control-automatically',
+ $pointer)
+ if $line =~ m{^\s*DEB_AUTO_UPDATE_DEBIAN_CONTROL\s*=\s*yes};
+
+ $self->pointed_hint('debian-rules-uses-deb-build-opts', $pointer)
+ if $line =~ m{\$[\(\{]DEB_BUILD_OPTS[\)\}]};
+
+ if ($line =~ m{^\s*DH_EXTRA_ADDONS\s*=\s*(.*)$}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('debian-rules-should-not-use-DH_EXTRA_ADDONS',
+ $pointer, $context);
+ }
+
+ $self->pointed_hint('debian-rules-uses-wrong-environment-variable',
+ $pointer)
+ if $line =~ m{\bDEB_[^_ \t]+FLAGS_(?:SET|APPEND)\b};
+
+ $self->pointed_hint('debian-rules-calls-pwd', $pointer)
+ if $line =~ m{\$[\(\{]PWD[\)\}]};
+
+ $self->pointed_hint(
+ 'debian-rules-should-not-use-sanitize-all-buildflag',$pointer)
+ if $line
+ =~ m{^\s*(?:export\s+)?DEB_BUILD_MAINT_OPTIONS\s*:?=.*\bsanitize=\+all\b};
+
+ $self->pointed_hint('debian-rules-uses-special-shell-variable',
+ $pointer)
+ if $line =~ m{\$[\(\{]_[\)\}]};
+
+ if ($line =~ m{(dh_builddeb\b.*--.*-[zZS].*)$}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('custom-compression-in-debian-rules',
+ $pointer, $context);
+ }
+
+ if ($line =~ m{(py3versions\s+([\w\-\s]*--installed|-\w*i\w*))}) {
+
+ my $context = $1;
+
+ $self->pointed_hint('debian-rules-uses-installed-python-versions',
+ $pointer, $context);
+ }
+
+ $self->pointed_hint('debian-rules-uses-as-needed-linker-flag',$pointer)
+ if $line =~ /--as-needed/ && $line !~ /--no-as-needed/;
+
+ if ($line =~ /(py3versions\s+([\w\-\s]*--supported|-\w*s\w*))/) {
+
+ my $context = $1;
+
+ $self->pointed_hint(
+'debian-rules-uses-supported-python-versions-without-python-all-build-depends',
+ $pointer,
+ $context
+ )unless $build_all_norestriction->satisfies($PYTHON3_ALL_DEPEND);
+ }
+
+ # General assignment - save the variable
+ if ($line =~ /^\s*(?:\S+\s+)*?(\S+)\s*[:\?\+]?=\s*(.*+)?$/s) {
+ # This is far too simple from a theoretical PoV, but should do
+ # rather well.
+ my ($var, $value) = ($1, $2);
+ $variables{$var} = $value;
+
+ $self->pointed_hint('unnecessary-source-date-epoch-assignment',
+ $pointer)
+ if $var eq 'SOURCE_DATE_EPOCH'
+ && !$build_all->satisfies(
+ 'dpkg-dev:any (>= 1.18.8) | debhelper:any (>= 10.10)');
+ }
+
+ # Keep track of whether this portion of debian/rules may be optional
+ if ($line =~ /^ifn?(?:eq|def)\s(.*)/) {
+ push(@conditionals, $1);
+ $maybe_skipping++;
+
+ } elsif ($line =~ /^endif\s/) {
+ $maybe_skipping--;
+ }
+
+ unless ($maybe_skipping) {
+
+ for my $prerequisite (keys %GLOBAL_DEPENDS) {
+
+ my @patterns = @{ $GLOBAL_DEPENDS{$prerequisite} };
+
+ push(@needed, $prerequisite)
+ if any { $line =~ $_ } @patterns;
+ }
+
+ for my $prerequisite (keys %GLOBAL_CLEAN_DEPENDS) {
+
+ my @patterns = @{ $GLOBAL_CLEAN_DEPENDS{$prerequisite} };
+
+ if (any { $line =~ $_ } @patterns) {
+
+ push(@needed, $prerequisite);
+ push(@needed_clean, $prerequisite);
+ }
+ }
+ }
+
+ # Listing a rule as a dependency of .PHONY is sufficient to make it
+ # present for the purposes of GNU make and therefore the Policy
+ # requirement.
+ if ($line =~ /^(?:[^:]+\s)?\.PHONY(?:\s[^:]+)?:(.+)/s) {
+
+ my @targets = split($SPACE, $1);
+ for my $target (@targets) {
+ # Is it $(VAR) ?
+ if ($target =~ /^\$[\(\{]([^\)\}]++)[\)\}]$/) {
+ my $name = $1;
+ my $val = $variables{$name};
+ if ($val) {
+ # we think we know what it will expand to - note
+ # we ought to "delay" it was a "=" variable rather
+ # than ":=" or "+=".
+
+ # discards empty elements at end, effectively trimming right
+ for (split(/\s+/, $val)) {
+ $seen{$target}++
+ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+ last;
+ }
+ # We don't know, so just mark the target as seen.
+ }
+ $seen{$target}++
+ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+
+ #.PHONY implies the rest will not match
+ next;
+ }
+
+ if ( !$includes
+ && $line
+ =~ /dpkg-parsechangelog.*(?:Source|Version|Date|Timestamp)/s) {
+
+ $self->pointed_hint('debian-rules-parses-dpkg-parsechangelog',
+ $pointer);
+ }
+
+ if ($line !~ /^ifn?(?:eq|def)\s/ && $line =~ /^([^\s:][^:]*):+(.*)/s) {
+ my ($target_names, $target_dependencies) = ($1, $2);
+ @current_targets = split $SPACE, $target_names;
+
+ my @quoted = map { quotemeta } split($SPACE, $target_dependencies);
+ s/\\\$\\\([^\):]+\\:([^=]+)\\=([^\)]+)\1\\\)/$2.*/g for @quoted;
+
+ my @depends = map { qr/^$_$/ } @quoted;
+
+ for my $target (@current_targets) {
+ $overridden{$1} = $position if $target =~ m/override_(.+)/;
+ if ($target =~ /%/) {
+ my $pattern = quotemeta $target;
+ $pattern =~ s/\\%/.*/g;
+ for my $rulebypolicy (keys %TAG_FOR_POLICY_TARGET) {
+ $seen{$rulebypolicy}++ if $rulebypolicy =~ m/$pattern/;
+ }
+ } else {
+ # Is it $(VAR) ?
+ if ($target =~ m/^\$[\(\{]([^\)\}]++)[\)\}]$/) {
+ my $name = $1;
+ my $val = $variables{$name};
+ if ($val) {
+ # we think we know what it will expand to - note
+ # we ought to "delay" it was a "=" variable rather
+ # than ":=" or "+=".
+ local $_ = undef;
+
+ # discards empty elements at end, effectively trimming right
+ for (split(/\s+/, $val)) {
+ $seen{$_}++
+ if exists $TAG_FOR_POLICY_TARGET{$_};
+ }
+ last;
+ }
+ # We don't know, so just mark the target as seen.
+ }
+ $seen{$target}++ if exists $TAG_FOR_POLICY_TARGET{$target};
+ }
+ if (any { $target =~ /$_/ } @arch_rules) {
+ push(@arch_rules, @depends);
+ }
+ }
+ undef %debhelper_group;
+
+ } elsif ($line =~ /^define /) {
+ # We don't want to think the body of the define is part of
+ # the previous rule or we'll get false positives on tags
+ # like binary-arch-rules-but-pkg-is-arch-indep. Treat a
+ # define as the end of the current rule, although that
+ # isn't very accurate either.
+ @current_targets = ();
+
+ } else {
+ # If we have non-empty, non-comment lines, store them for
+ # all current targets and check whether debhelper programs
+ # are called in a reasonable order.
+ if ($line =~ /^\s+[^\#]/) {
+ my ($arch, $indep) = (0, 0);
+ for my $target (@current_targets) {
+ $rules_per_target{$target} ||= [];
+ push(@{$rules_per_target{$target}}, $line);
+
+ $arch = 1
+ if any { $target =~ /$_/ } @arch_rules;
+
+ $indep = 1
+ if any { $target eq $_ } @indep_rules;
+
+ $indep = 1
+ if $target eq $PERCENT;
+
+ $indep = 1
+ if $target =~ /^override_/;
+ }
+
+ if (!$maybe_skipping && ($arch || $indep)) {
+
+ for my $prerequisite (keys %RULE_CLEAN_DEPENDS) {
+
+ my @patterns = @{ $RULE_CLEAN_DEPENDS{$prerequisite} };
+
+ if (any { $line =~ $_ } @patterns) {
+
+ push(@needed, $prerequisite);
+ push(@needed_clean, $prerequisite)
+ if $arch;
+ }
+ }
+ }
+
+ if ($line =~ /^\s+(dh_\S+)\b/ && $debhelper_order{$1}) {
+ my $command = $1;
+ my ($package) = ($line =~ /\s(?:-p|--package=)(\S+)/);
+ $package ||= $EMPTY;
+ my $group = $debhelper_order{$command};
+ $debhelper_group{$package} ||= 0;
+
+ if ($group < $debhelper_group{$package}) {
+
+ $self->pointed_hint(
+ 'debian-rules-calls-debhelper-in-odd-order',
+ $pointer, $command);
+
+ } else {
+ $debhelper_group{$package} = $group;
+ }
+ }
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ my @missing_targets;
+ @missing_targets = grep { !$seen{$_} } keys %TAG_FOR_POLICY_TARGET
+ unless $includes;
+
+ $self->pointed_hint($TAG_FOR_POLICY_TARGET{$_}, $rules->pointer, $_)
+ for @missing_targets;
+
+ # Make sure we have no content for binary-arch if we are arch-indep:
+ $rules_per_target{'binary-arch'} ||= [];
+ if ($architecture eq 'all' && scalar @{$rules_per_target{'binary-arch'}}) {
+
+ my $nonempty = 0;
+ for my $rule (@{$rules_per_target{'binary-arch'}}) {
+ # dh binary-arch is actually a no-op if there is no
+ # Architecture: any package in the control file
+ $nonempty = 1
+ unless $rule =~ /^\s*dh\s+(?:binary-arch|\$\@)/;
+ }
+
+ $self->pointed_hint('binary-arch-rules-but-pkg-is-arch-indep',
+ $rules->pointer)
+ if $nonempty;
+ }
+
+ for my $cmd (qw(dh_clean dh_fixperms)) {
+ for my $suffix ($EMPTY, '-indep', '-arch') {
+
+ my $memorized_position = $overridden{"$cmd$suffix"};
+ next
+ unless defined $memorized_position;
+
+ $self->pointed_hint(
+ "override_$cmd-does-not-call-$cmd",
+ $rules->pointer($memorized_position)
+ )
+ if none { m/^\t\s*-?($cmd\b|\$\(overridden_command\))/ }
+ @{$rules_per_target{"override_$cmd$suffix"}};
+ }
+ }
+
+ if (my $memorized_position = $overridden{'dh_auto_test'}) {
+
+ my @rules = grep {
+ !m{^\t\s*[\:\[]}
+ && !m{^\s*$}
+ && !m{\bdh_auto_test\b}
+ && !
+m{^\t\s*[-@]?(?:(?:/usr)?/bin/)?(?:cp|chmod|echo|ln|mv|mkdir|rm|test|true)}
+ } @{$rules_per_target{'override_dh_auto_test'}};
+
+ $self->pointed_hint(
+ 'override_dh_auto_test-does-not-check-DEB_BUILD_OPTIONS',
+ $rules->pointer($memorized_position))
+ if @rules and none { m/(DEB_BUILD_OPTIONS|nocheck)/ } @conditionals;
+ }
+
+ $self->pointed_hint(
+ 'debian-rules-contains-unnecessary-get-orig-source-target',
+ $rules->pointer)
+ if any { m/^\s+uscan\b/ } @{$rules_per_target{'get-orig-source'}};
+
+ my @clean_in_indep
+ = grep { $build_indep->satisfies($_) } uniq @needed_clean;
+ $self->pointed_hint(
+ 'missing-build-depends-for-clean-target-in-debian-rules',
+ $rules->pointer, "(does not satisfy $_)")
+ for @clean_in_indep;
+
+ # another check complains when debhelper is missing from d/rules
+ my $combined_lc = List::Compare->new(\@needed, ['debhelper:any']);
+
+ my @still_missing
+ = grep { !$build_all_norestriction->satisfies($_) }
+ $combined_lc->get_Lonly;
+
+ $self->pointed_hint('rules-require-build-prerequisite',
+ $rules->pointer, "(does not satisfy $_)")
+ for @still_missing;
+
+ $self->pointed_hint('debian-rules-should-not-set-CFLAGS-from-noopt',
+ $rules->pointer)
+ if $contents
+ =~ m{^ ifn?eq \s+ [(] , \$ [(] findstring \s+ noopt , \$ [(] DEB_BUILD_OPTIONS [)] [)] [)] \n+
+ \t+ CFLAGS \s+ \+ = \s+ -O[02] \n+
+ else \n+
+ \t+ CFLAGS \s+ \+ = \s+ -O[02] \n+
+ endif $}xsm;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Rules/DhSequencer.pm b/lib/Lintian/Check/Debian/Rules/DhSequencer.pm
new file mode 100644
index 0000000..bc2b239
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Rules/DhSequencer.pm
@@ -0,0 +1,65 @@
+# debian/rules/dh-sequencer -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Rules::DhSequencer;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/rules';
+
+ my $bytes = $item->bytes;
+
+ # strip comments (see #960485)
+ $bytes =~ s/^\h#.*\R?//mg;
+
+ my $plain = qr/\$\@/;
+ my $curly = qr/\$\{\@\}/;
+ my $asterisk = qr/\$\*/;
+ my $parentheses = qr/\$\(\@\)/;
+ my $rule_altern = qr/(?:$plain|$curly|$asterisk|$parentheses)/;
+ my $rule_target = qr/(?:$rule_altern|'$rule_altern'|"$rule_altern")/;
+
+ $self->pointed_hint('no-dh-sequencer', $item->pointer)
+ unless $bytes =~ /^\t+(?:[\+@-])?(?:[^=]+=\S+ )?dh[ \t]+$rule_target/m
+ || $bytes =~ m{^\s*include\s+/usr/share/cdbs/1/class/hlibrary.mk\s*$}m
+ || $bytes =~ m{\bDEB_CABAL_PACKAGE\b};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Shlibs.pm b/lib/Lintian/Check/Debian/Shlibs.pm
new file mode 100644
index 0000000..8e755d9
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Shlibs.pm
@@ -0,0 +1,656 @@
+# debian/shlibs -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Shlibs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::Compare;
+use List::SomeUtils qw(any none uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $EQUALS => q{=};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+my @known_meta_labels = qw{
+ Build-Depends-Package
+ Build-Depends-Packages
+ Ignore-Blacklist-Groups
+};
+
+has soname_by_filename => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %soname_by_filename;
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ $soname_by_filename{$item->name}= $item->elf->{SONAME}[0]
+ if exists $item->elf->{SONAME};
+ }
+
+ return \%soname_by_filename;
+ }
+);
+
+has shlibs_positions_by_pretty_soname => (is => 'rw', default => sub { {} });
+has symbols_positions_by_soname => (is => 'rw', default => sub { {} });
+
+sub installable {
+ my ($self) = @_;
+
+ $self->check_shlibs_file;
+ $self->check_symbols_file;
+
+ my @pretty_sonames_from_shlibs
+ = keys %{$self->shlibs_positions_by_pretty_soname};
+ my @pretty_sonames_from_symbols
+ = map { human_soname($_) } keys %{$self->symbols_positions_by_soname};
+
+ # Compare the contents of the shlibs and symbols control files, but exclude
+ # from this check shared libraries whose SONAMEs has no version. Those can
+ # only be represented in symbols files and aren't expected in shlibs files.
+ my $extra_lc = List::Compare->new(\@pretty_sonames_from_symbols,
+ \@pretty_sonames_from_shlibs);
+
+ if (%{$self->shlibs_positions_by_pretty_soname}) {
+
+ my @versioned = grep { m{ } } $extra_lc->get_Lonly;
+
+ $self->hint('symbols-for-undeclared-shared-library', $_)for @versioned;
+ }
+
+ return;
+}
+
+sub check_shlibs_file {
+ my ($self) = @_;
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+
+ # Libraries with no version information can't be represented by
+ # the shlibs format (but can be represented by symbols). We want
+ # to warn about them if they appear in public directories. If
+ # they're in private directories, assume they're plugins or
+ # private libraries and are safe.
+ my @unversioned_libraries;
+ for my $file_name (keys %{$self->soname_by_filename}) {
+
+ my $pretty_soname
+ = human_soname($self->soname_by_filename->{$file_name});
+ next
+ if $pretty_soname =~ m{ };
+
+ push(@unversioned_libraries, $file_name);
+ $self->hint('shared-library-lacks-version', $file_name, $pretty_soname)
+ if any { (dirname($file_name) . $SLASH) eq $_ } @ldconfig_folders;
+ }
+
+ my $versioned_lc = List::Compare->new([keys %{$self->soname_by_filename}],
+ \@unversioned_libraries);
+ my @versioned_libraries = $versioned_lc->get_Lonly;
+
+ # 4th step: check shlibs control file
+ # $package_version may be undef in very broken packages
+ my $shlibs_file = $self->processable->control->lookup('shlibs');
+ $shlibs_file = undef
+ if defined $shlibs_file && !$shlibs_file->is_file;
+
+ # no shared libraries included in package, thus shlibs control
+ # file should not be present
+ $self->pointed_hint('empty-shlibs', $shlibs_file->pointer)
+ if defined $shlibs_file && !@versioned_libraries;
+
+ # shared libraries included, thus shlibs control file has to exist
+ for my $file_name (@versioned_libraries) {
+
+ # only public shared libraries
+ $self->hint('no-shlibs', $file_name)
+ if (any { (dirname($file_name) . $SLASH) eq $_ } @ldconfig_folders)
+ && !defined $shlibs_file
+ && $self->processable->type ne 'udeb'
+ && !is_nss_plugin($file_name);
+ }
+
+ if (@versioned_libraries && defined $shlibs_file) {
+
+ my @shlibs_prerequisites;
+
+ my @lines = split(/\n/, $shlibs_file->decoded_utf8);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ if $line =~ m{^ \s* $}x
+ || $line =~ m{^ [#] }x;
+
+ # We exclude udebs from the checks for correct shared library
+ # dependencies, since packages may contain dependencies on
+ # other udeb packages.
+
+ my $udeb = $EMPTY;
+ $udeb = 'udeb: '
+ if $line =~ s/^udeb:\s+//;
+
+ my ($name, $version, @prerequisites) = split($SPACE, $line);
+ my $pretty_soname = "$udeb$name $version";
+
+ $self->shlibs_positions_by_pretty_soname->{$pretty_soname} //= [];
+ push(
+ @{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}},
+ $position
+ );
+
+ push(@shlibs_prerequisites, join($SPACE, @prerequisites))
+ unless $udeb;
+
+ } continue {
+ ++$position;
+ }
+
+ my @duplicate_pretty_sonames
+ = grep { @{$self->shlibs_positions_by_pretty_soname->{$_}} > 1 }
+ keys %{$self->shlibs_positions_by_pretty_soname};
+
+ for my $pretty_soname (@duplicate_pretty_sonames) {
+
+ my $indicator
+ = $LEFT_PARENTHESIS . 'lines'
+ . $SPACE
+ . join($SPACE,
+ sort { $a <=> $b }
+ @{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}}
+ ). $RIGHT_PARENTHESIS;
+
+ $self->pointed_hint('duplicate-in-shlibs', $shlibs_file->pointer,
+ $indicator,$pretty_soname);
+ }
+
+ my @used_pretty_sonames;
+ for my $file_name (@versioned_libraries) {
+
+ my $pretty_soname
+ = human_soname($self->soname_by_filename->{$file_name});
+
+ push(@used_pretty_sonames, $pretty_soname);
+ push(@used_pretty_sonames, "udeb: $pretty_soname");
+
+ # only public shared libraries
+ $self->pointed_hint('ships-undeclared-shared-library',
+ $shlibs_file->pointer,$pretty_soname, 'for', $file_name)
+ if (any { (dirname($file_name) . $SLASH) eq $_ }
+ @ldconfig_folders)
+ && !@{$self->shlibs_positions_by_pretty_soname->{$pretty_soname}
+ // []}
+ && !is_nss_plugin($file_name);
+ }
+
+ my $unused_lc
+ = List::Compare->new(
+ [keys %{$self->shlibs_positions_by_pretty_soname}],
+ \@used_pretty_sonames);
+
+ $self->pointed_hint('shared-library-not-shipped',
+ $shlibs_file->pointer, $_)
+ for $unused_lc->get_Lonly;
+
+ my $fields = $self->processable->fields;
+
+ # Check that all of the packages listed as dependencies in
+ # the shlibs file are satisfied by the current package or
+ # its Provides. Normally, packages should only declare
+ # dependencies in their shlibs that they themselves can
+ # satisfy.
+ my $provides = $self->processable->name;
+ $provides
+ .= $LEFT_PARENTHESIS
+ . $EQUALS
+ . $SPACE
+ . $fields->value('Version')
+ . $RIGHT_PARENTHESIS
+ if $fields->declares('Version');
+
+ $provides
+ = $self->processable->relation('Provides')->logical_and($provides);
+
+ for my $prerequisite (uniq @shlibs_prerequisites) {
+
+ $self->pointed_hint('distant-prerequisite-in-shlibs',
+ $shlibs_file->pointer, $prerequisite)
+ unless $provides->satisfies($prerequisite);
+
+ $self->pointed_hint('outdated-relation-in-shlibs',
+ $shlibs_file->pointer, $prerequisite)
+ if $prerequisite =~ m/\(\s*[><](?![<>=])\s*/;
+ }
+ }
+
+ return;
+}
+
+sub check_symbols_file {
+ my ($self) = @_;
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+ my @shared_libraries = keys %{$self->soname_by_filename};
+
+ my $fields = $self->processable->fields;
+ my $symbols_file = $self->processable->control->lookup('symbols');
+
+ if (!defined $symbols_file
+ && $self->processable->type ne 'udeb') {
+
+ for my $file_name (@shared_libraries){
+
+ my $item = $self->processable->installed->lookup($file_name);
+ next
+ unless defined $item;
+
+ my @symbols
+ = grep { $_->section eq '.text' || $_->section eq 'UND' }
+ @{$item->elf->{SYMBOLS} // []};
+
+ # only public shared libraries
+ # Skip Objective C libraries as instance/class methods do not
+ # appear in the symbol table
+ $self->hint('no-symbols-control-file', $file_name)
+ if (any { (dirname($file_name) . $SLASH) eq $_ }
+ @ldconfig_folders)
+ && (none { $_->name =~ m/^__objc_/ } @symbols)
+ && !is_nss_plugin($file_name);
+ }
+ }
+
+ return
+ unless defined $symbols_file;
+
+ # no shared libraries included in package, thus symbols
+ # control file should not be present
+ $self->pointed_hint('empty-shared-library-symbols', $symbols_file->pointer)
+ unless @shared_libraries;
+
+ # Assume the version to be a non-native version to avoid
+ # uninitialization warnings later.
+ my $package_version = $fields->value('Version') || '0-1';
+
+ my $package_version_wo_rev = $package_version;
+ $package_version_wo_rev =~ s/^ (.+) - [^-]+ $/$1/x;
+
+ my @sonames;
+ my %symbols_by_soname;
+ my %full_version_symbols_by_soname;
+ my %debian_revision_symbols_by_soname;
+ my %prerequisites_by_soname;
+ my %positions_by_soname_and_meta_label;
+ my @syntax_errors;
+ my $template_count = 0;
+
+ my @lines = split(/\n/, $symbols_file->decoded_utf8);
+
+ my $current_soname = $EMPTY;
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ if $line =~ m{^ \s* $}x
+ || $line =~ m{^ [#] }x;
+
+ # soname, main dependency template
+ if ($line
+ =~ m{^ ([^\s|*]\S+) \s\S+\s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#] )? }x
+ ){
+
+ $current_soname = $1;
+ push(@sonames, $current_soname);
+
+ $line =~ s/^\Q$current_soname\E\s*//;
+
+ $self->symbols_positions_by_soname->{$current_soname} //= [];
+ push(
+ @{$self->symbols_positions_by_soname->{$current_soname}},
+ $position
+ );
+
+ for my $conjunctive (split(m{ \s* , \s* }x, $line)) {
+ for my $disjunctive (split(m{ \s* [|] \s* }x, $conjunctive)){
+
+ $disjunctive
+ =~ m{^ (\S+) ( \s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#]))? $}x;
+
+ my $package = $1;
+ my $version = $2 || $EMPTY;
+
+ if (length $package) {
+ $prerequisites_by_soname{$current_soname} //= [];
+ push(
+ @{$prerequisites_by_soname{$current_soname}},
+ $package . $version
+ );
+
+ } else {
+ push(@syntax_errors, $position);
+ }
+ }
+ }
+
+ $template_count = 0;
+
+ next;
+ }
+
+ # alternative dependency template
+ if ($line
+ =~ m{^ [|] \s+\S+\s* (?: [(] \S+\s+\S+ [)] | [#]MINVER[#] )? }x) {
+
+ my $error = 0;
+
+ if (%{$positions_by_soname_and_meta_label{$current_soname} // {} }
+ || !length $current_soname) {
+
+ push(@syntax_errors, $position);
+ $error = 1;
+ }
+
+ $line =~ s{^ [|] \s* }{}x;
+
+ for my $conjunctive (split(m{ \s* , \s* }x, $line)) {
+ for my $disjunctive (split(m{ \s* [|] \s* }x, $conjunctive)) {
+
+ $disjunctive
+ =~ m{^ (\S+) ( \s* (?: [(] \S+ \s+ \S+ [)] | [#]MINVER[#] ) )? $}x;
+
+ my $package = $1;
+ my $version = $2 || $EMPTY;
+
+ if (length $package) {
+ $prerequisites_by_soname{$current_soname} //= [];
+ push(
+ @{$prerequisites_by_soname{$current_soname}},
+ $package . $version
+ );
+
+ } else {
+ push(@syntax_errors, $position)
+ unless $error;
+
+ $error = 1;
+ }
+ }
+ }
+
+ $template_count++ unless $error;
+
+ next;
+ }
+
+ # meta-information
+ if ($line =~ m{^ [*] \s (\S+) : \s \S+ }x) {
+
+ my $meta_label = $1;
+
+ $positions_by_soname_and_meta_label{$current_soname}{$meta_label}
+ //= [];
+ push(
+ @{
+ $positions_by_soname_and_meta_label{$current_soname}
+ {$meta_label}
+ },
+ $position
+ );
+
+ push(@syntax_errors, $position)
+ if !defined $current_soname
+ || @{$symbols_by_soname{$current_soname} // [] };
+
+ next;
+ }
+
+ # Symbol definition
+ if ($line =~ m{^\s+ (\S+) \s (\S+) (?:\s (\S+ (?:\s\S+)? ) )? $}x) {
+
+ my $symbol = $1;
+ my $version = $2;
+ my $selector = $3 // $EMPTY;
+
+ push(@syntax_errors, $position)
+ unless length $current_soname;
+
+ $symbols_by_soname{$current_soname} //= [];
+ push(@{$symbols_by_soname{$current_soname}}, $symbol);
+
+ if ($version eq $package_version && $package_version =~ m{-}) {
+ $full_version_symbols_by_soname{$current_soname} //= [];
+ push(
+ @{$full_version_symbols_by_soname{$current_soname}},
+ $symbol
+ );
+
+ } elsif ($version =~ m{-}
+ && $version !~ m{~$}
+ && $version ne $package_version_wo_rev) {
+
+ $debian_revision_symbols_by_soname{$current_soname} //= [];
+ push(
+ @{$debian_revision_symbols_by_soname{$current_soname}},
+ $symbol
+ );
+ }
+
+ $self->pointed_hint('invalid-template-id-in-symbols-file',
+ $symbols_file->pointer($position),$selector)
+ if length $selector
+ && ($selector !~ m{^ \d+ $}x || $selector > $template_count);
+
+ next;
+ }
+
+ push(@syntax_errors, $position);
+
+ } continue {
+ ++$position;
+ }
+
+ my @duplicate_sonames
+ = grep { @{$self->symbols_positions_by_soname->{$_}} > 1 }
+ keys %{$self->symbols_positions_by_soname};
+
+ for my $soname (@duplicate_sonames) {
+
+ my $indicator
+ = $LEFT_PARENTHESIS . 'lines'
+ . $SPACE
+ . join($SPACE,
+ sort { $a <=> $b }@{$self->symbols_positions_by_soname->{$soname}})
+ . $RIGHT_PARENTHESIS;
+
+ my $pretty_soname = human_soname($soname);
+
+ $self->pointed_hint('duplicate-entry-in-symbols-control-file',
+ $symbols_file->pointer,$indicator,$pretty_soname);
+ }
+
+ $self->pointed_hint('syntax-error-in-symbols-file',
+ $symbols_file->pointer($_))
+ for uniq @syntax_errors;
+
+ # Check that all of the packages listed as dependencies in the symbols
+ # file are satisfied by the current package or its Provides.
+ # Normally, packages should only declare dependencies in their symbols
+ # files that they themselves can satisfy.
+ my $provides = $self->processable->name;
+ $provides
+ .= $LEFT_PARENTHESIS
+ . $EQUALS
+ . $SPACE
+ . $fields->value('Version')
+ . $RIGHT_PARENTHESIS
+ if $fields->declares('Version');
+
+ $provides
+ = $self->processable->relation('Provides')->logical_and($provides);
+
+ for my $soname (uniq @sonames) {
+
+ my @used_meta_labels
+ = keys %{$positions_by_soname_and_meta_label{$soname} // {} };
+
+ my $meta_lc
+ = List::Compare->new(\@used_meta_labels, \@known_meta_labels);
+
+ for my $meta_label ($meta_lc->get_Lonly) {
+
+ $self->pointed_hint(
+ 'unknown-meta-field-in-symbols-file',
+ $symbols_file->pointer($_),
+ $meta_label, "($soname)"
+ )
+ for @{$positions_by_soname_and_meta_label{$soname}{$meta_label}};
+ }
+
+ $self->pointed_hint('symbols-file-missing-build-depends-package-field',
+ $symbols_file->pointer,$soname)
+ if none { $_ eq 'Build-Depends-Package' } @used_meta_labels;
+
+ my @full_version_symbols
+ = @{$full_version_symbols_by_soname{$soname} // [] };
+ if (@full_version_symbols) {
+
+ my @sorted = sort +uniq @full_version_symbols;
+
+ my $context = 'on symbol ' . $sorted[0];
+ $context .= ' and ' . (scalar @sorted - 1) . ' others'
+ if @sorted > 1;
+
+ $self->pointed_hint(
+ 'symbols-file-contains-current-version-with-debian-revision',
+ $symbols_file->pointer,$context, "($soname)");
+ }
+
+ my @debian_revision_symbols
+ = @{$debian_revision_symbols_by_soname{$soname} // [] };
+ if (@debian_revision_symbols) {
+
+ my @sorted = sort +uniq @debian_revision_symbols;
+
+ my $context = 'on symbol ' . $sorted[0];
+ $context .= ' and ' . (scalar @sorted - 1) . ' others'
+ if @sorted > 1;
+
+ $self->pointed_hint('symbols-file-contains-debian-revision',
+ $symbols_file->pointer,$context, "($soname)");
+ }
+
+ # Deduplicate the list of dependencies before warning so that we don't
+ # duplicate warnings.
+ for
+ my $prerequisite (uniq @{$prerequisites_by_soname{$soname} // [] }) {
+
+ $prerequisite =~ s/ [ ] [#] MINVER [#] $//x;
+ $self->pointed_hint('symbols-declares-dependency-on-other-package',
+ $symbols_file->pointer,$prerequisite, "($soname)")
+ unless $provides->satisfies($prerequisite);
+ }
+ }
+
+ my @used_pretty_sonames;
+ for my $filename (@shared_libraries) {
+
+ my $soname = $self->soname_by_filename->{$filename};
+ my $pretty_soname = human_soname($soname);
+
+ push(@used_pretty_sonames, $pretty_soname);
+ push(@used_pretty_sonames, "udeb: $pretty_soname");
+
+ # only public shared libraries
+ $self->pointed_hint('shared-library-symbols-not-tracked',
+ $symbols_file->pointer,$pretty_soname,'for', $filename)
+ if (any { (dirname($filename) . $SLASH) eq $_ }@ldconfig_folders)
+ && !@{$self->symbols_positions_by_soname->{$soname}// [] }
+ && !is_nss_plugin($filename);
+ }
+
+ my @available_pretty_sonames
+ = map { human_soname($_) } keys %{$self->symbols_positions_by_soname};
+
+ my $unused_lc
+ = List::Compare->new(\@available_pretty_sonames,\@used_pretty_sonames);
+
+ $self->pointed_hint('surplus-shared-library-symbols',
+ $symbols_file->pointer, $_)
+ for $unused_lc->get_Lonly;
+
+ return;
+}
+
+# Extract the library name and the version from an SONAME and return them
+# separated by a space. This code should match the split_soname function in
+# dpkg-shlibdeps.
+sub human_soname {
+ my ($string) = @_;
+
+ # libfoo.so.X.X
+ # libfoo-X.X.so
+ if ( $string =~ m{^ (.*) [.]so[.] (.*) $}x
+ || $string =~ m{^ (.*) - (\d.*) [.]so $}x) {
+
+ my $name = $1;
+ my $version = $2;
+
+ return $name . $SPACE . $version;
+ }
+
+ return $string;
+}
+
+# Returns a truth value if the first argument appears to be the path
+# to a libc nss plugin (libnss_<name>.so.$version).
+sub is_nss_plugin {
+ my ($name) = @_;
+
+ return 1
+ if $name =~ m{^ (?:.*/)? libnss_[^.]+ [.]so[.] \d+ $}x;
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm b/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm
new file mode 100644
index 0000000..48e8926
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Source/IncludeBinaries.pm
@@ -0,0 +1,77 @@
+# debian/source/include-binaries -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Source::IncludeBinaries;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $sourcedir= $self->processable->patched->resolve_path('debian/source/');
+ return
+ unless $sourcedir;
+
+ my $item = $sourcedir->child('include-binaries');
+ return
+ unless $item && $item->is_open_ok;
+
+ my @lines = path($item->unpacked_path)->lines({ chomp => 1 });
+
+ # format described in dpkg-source (1)
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ if $line =~ /^\s*$/;
+
+ next
+ if $line =~ /^#/;
+
+ # trim both ends
+ $line =~ s/^\s+|\s+$//g;
+
+ $self->pointed_hint('unused-entry-in-debian-source-include-binaries',
+ $item->pointer($position), $line)
+ unless $self->processable->patched->resolve_path($line);
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/SourceDir.pm b/lib/Lintian/Check/Debian/SourceDir.pm
new file mode 100644
index 0000000..2fd2ebf
--- /dev/null
+++ b/lib/Lintian/Check/Debian/SourceDir.pm
@@ -0,0 +1,170 @@
+# debian/source directory content -- lintian check script -*- perl -*-
+
+# Copyright (C) 2010 by Raphael Hertzog
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::SourceDir;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+our %KNOWN_FORMATS = map { $_ => 1 }
+ ('1.0', '2.0', '3.0 (quilt)', '3.0 (native)', '3.0 (git)', '3.0 (bzr)');
+
+my %OLDER_FORMATS = map { $_ => 1 }('1.0');
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ my $dsrc = $processable->patched->resolve_path('debian/source/');
+ my ($format_file, $git_pfile, $format, $format_extra);
+
+ $format_file = $dsrc->child('format') if $dsrc;
+
+ if ($format_file and $format_file->is_open_ok) {
+
+ open(my $fd, '<', $format_file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $format_file->unpacked_path);
+
+ $format = <$fd>;
+ chomp $format;
+ close($fd);
+ $format_extra = $EMPTY;
+ die encode_utf8("unknown source format $format")
+ unless $KNOWN_FORMATS{$format};
+ } else {
+ $self->hint('missing-debian-source-format');
+ $format = '1.0';
+ $format_extra = 'implicit';
+ }
+ if ($format eq '1.0') {
+ $format_extra .= $SPACE if $format_extra;
+ if (keys %{$processable->diffstat}) {
+ $format_extra .= 'non-native';
+ } else {
+ $format_extra .= 'native';
+ }
+ }
+ my $format_info = $format;
+ $format_info .= " [$format_extra]"
+ if $format_extra;
+ $self->hint('source-format', $format_info);
+
+ $self->hint('older-source-format', $format) if $OLDER_FORMATS{$format};
+
+ return if not $dsrc;
+
+ $git_pfile = $dsrc->child('git-patches');
+
+ if ($git_pfile and $git_pfile->is_open_ok and $git_pfile->size != 0) {
+
+ open(my $git_patches_fd, '<', $git_pfile->unpacked_path)
+ or die encode_utf8('Cannot open ' . $git_pfile->unpacked_path);
+
+ if (any { !/^\s*+#|^\s*+$/} <$git_patches_fd>) {
+ my $dpseries
+ = $processable->patched->resolve_path('debian/patches/series');
+ # gitpkg does not create series as a link, so this is most likely
+ # a traversal attempt.
+ if (not $dpseries or not $dpseries->is_open_ok) {
+
+ $self->pointed_hint('git-patches-not-exported',
+ $git_pfile->pointer);
+
+ } else {
+ open(my $series_fd, '<', $dpseries->unpacked_path)
+ or
+ die encode_utf8('Cannot open ' . $dpseries->unpacked_path);
+
+ my $comment_line = <$series_fd>;
+ my $count = grep { !/^\s*+\#|^\s*+$/ } <$series_fd>;
+
+ $self->pointed_hint('git-patches-not-exported',
+ $dpseries->pointer)
+ unless (
+ $count
+ && ($comment_line
+ =~ /^\s*\#.*quilt-patches-deb-export-hook/)
+ );
+
+ close $series_fd;
+ }
+ }
+ close $git_patches_fd;
+ }
+
+ my $KNOWN_FILES= $self->data->load('debian-source-dir/known-files');
+
+ my @files = grep { !$_->is_dir } $dsrc->children;
+ for my $item (@files) {
+
+ $self->pointed_hint('unknown-file-in-debian-source', $item->pointer)
+ unless $KNOWN_FILES->recognizes($item->basename);
+ }
+
+ my $options = $processable->patched->resolve_path('debian/source/options');
+ if ($options and $options->is_open_ok) {
+
+ open(my $fd, '<', $options->unpacked_path)
+ or die encode_utf8('Cannot open ' . $options->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ if ($line =~ /^\s*(compression(?:-level)?\s*=\s+\S+)\n/) {
+
+ my $level = $1;
+
+ $self->pointed_hint(
+ 'custom-compression-in-debian-source-options',
+ $options->pointer($position), $level);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Substvars.pm b/lib/Lintian/Check/Debian/Substvars.pm
new file mode 100644
index 0000000..d612783
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Substvars.pm
@@ -0,0 +1,55 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Substvars;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('source-contains-debian-substvars', $item->pointer)
+ if $item->name =~ m{^debian/(?:.+\.)?substvars$}s;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Symbols.pm b/lib/Lintian/Check/Debian/Symbols.pm
new file mode 100644
index 0000000..42b36fe
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Symbols.pm
@@ -0,0 +1,83 @@
+# debian/symbols -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Symbols;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ # look at symbols files
+ return
+ unless $item->name =~ qr{^ debian/ (?:.+[.]) symbols $}x;
+
+ return
+ unless $item->is_file && $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chop $line;
+ next
+ if $line =~ /^\s*$/
+ || $line =~ /^#/;
+
+ # meta-information
+ if ($line =~ /^\*\s(\S+):\s+(\S+)/) {
+
+ my $field = $1;
+ my $value = $2;
+
+ $self->pointed_hint('package-placeholder-in-symbols-file',
+ $item->pointer($position))
+ if $field eq 'Build-Depends-Package' && $value =~ /#PACKAGE#/;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/TrailingWhitespace.pm b/lib/Lintian/Check/Debian/TrailingWhitespace.pm
new file mode 100644
index 0000000..465fa59
--- /dev/null
+++ b/lib/Lintian/Check/Debian/TrailingWhitespace.pm
@@ -0,0 +1,105 @@
+# debian/trailing-whitespace -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::TrailingWhitespace;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $KEEP_EMPTY_FIELDS => -1;
+const my $LAST_ITEM => -1;
+
+# list of files to check for a trailing whitespace characters
+my %PROHIBITED_TRAILS = (
+ 'debian/changelog' => qr{\s+$},
+ 'debian/control' => qr{\s+$},
+ # allow trailing tabs in make
+ 'debian/rules' => qr{[ ]+$},
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless exists $PROHIBITED_TRAILS{$item->name};
+
+ return
+ unless $item->is_valid_utf8;
+
+ my $contents = $item->decoded_utf8;
+ my @lines = split(/\n/, $contents, $KEEP_EMPTY_FIELDS);
+
+ my @trailing_whitespace;
+ my @empty_at_end;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ push(@trailing_whitespace, $position)
+ if $line =~ $PROHIBITED_TRAILS{$item->name};
+
+ # keeps track of any empty lines at the end
+ if (length $line) {
+ @empty_at_end = ();
+ } else {
+ push(@empty_at_end, $position);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ # require a newline at end and remove it
+ if (scalar @empty_at_end && $empty_at_end[$LAST_ITEM] == scalar @lines){
+ pop @empty_at_end;
+ } else {
+ $self->pointed_hint('no-newline-at-end', $item->pointer);
+ }
+
+ push(@trailing_whitespace, @empty_at_end);
+
+ $self->pointed_hint('trailing-whitespace', $item->pointer($_))
+ for @trailing_whitespace;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Upstream/Metadata.pm b/lib/Lintian/Check/Debian/Upstream/Metadata.pm
new file mode 100644
index 0000000..410733a
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Upstream/Metadata.pm
@@ -0,0 +1,191 @@
+# debian/upstream/metadata -- lintian check script -*- perl -*-
+
+# Copyright (C) 2016 Petter Reinholdtsen
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Jelmer Vernooij
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Upstream::Metadata;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::Util qw(none);
+use Syntax::Keyword::Try;
+use YAML::XS;
+
+# default changed to false in 0.81; enable then in .perlcriticrc
+$YAML::XS::LoadBlessed = 0;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# Need 0.69 for $LoadBlessed (#861958)
+const my $HAS_LOAD_BLESSED => 0.69;
+
+# taken from https://wiki.debian.org/UpstreamMetadata
+my @known_fields = qw(
+ Archive
+ ASCL-Id
+ Bug-Database
+ Bug-Submit
+ Cite-As
+ Changelog
+ CPE
+ Documentation
+ Donation
+ FAQ
+ Funding
+ Gallery
+ Other-References
+ Reference
+ Registration
+ Registry
+ Repository
+ Repository-Browse
+ Screenshots
+ Security-Contact
+ Webservice
+);
+
+# tolerated for packages not using DEP-5 copyright
+my @tolerated_fields = qw(
+ Name
+ Contact
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $item
+ = $self->processable->patched->resolve_path('debian/upstream/metadata');
+
+ if ($self->processable->native) {
+
+ $self->pointed_hint('upstream-metadata-in-native-source',
+ $item->pointer)
+ if defined $item;
+ return;
+ }
+
+ unless (defined $item) {
+ $self->hint('upstream-metadata-file-is-missing');
+ return;
+ }
+
+ $self->pointed_hint('upstream-metadata-exists', $item->pointer);
+
+ unless ($item->is_open_ok) {
+ $self->pointed_hint('upstream-metadata-is-not-a-file', $item->pointer);
+ return;
+ }
+
+ return
+ if $YAML::XS::VERSION < $HAS_LOAD_BLESSED;
+
+ my $yaml;
+ try {
+ $yaml = YAML::XS::LoadFile($item->unpacked_path);
+
+ die
+ unless defined $yaml;
+
+ } catch {
+
+ my $message = $@;
+ my ($reason, $document, $line, $column)= (
+ $message =~ m{
+ \AYAML::XS::Load\sError:\sThe\sproblem:\n
+ \n\s++(.+)\n
+ \n
+ was\sfound\sat\sdocument:\s(\d+),\sline:\s(\d+),\scolumn:\s(\d+)\n}x
+ );
+
+ $message
+ = "$reason (at document $document, line $line, column $column)"
+ if ( length $reason
+ && length $document
+ && length $line
+ && length $document);
+
+ $self->pointed_hint('upstream-metadata-yaml-invalid',
+ $item->pointer, $message);
+
+ return;
+ }
+
+ unless (ref $yaml eq 'HASH') {
+
+ $self->pointed_hint('upstream-metadata-not-yaml-mapping',
+ $item->pointer);
+ return;
+ }
+
+ for my $field (keys %{$yaml}) {
+
+ $self->pointed_hint('upstream-metadata', $item->pointer, $field,
+ $yaml->{$field})
+ if ref($yaml->{$field}) eq $EMPTY;
+ }
+
+ my $lc
+ = List::Compare->new([keys %{$yaml}],[@known_fields, @tolerated_fields]);
+ my @invalid_fields = $lc->get_Lonly;
+
+ $self->pointed_hint('upstream-metadata-field-unknown', $item->pointer, $_)
+ for @invalid_fields;
+
+ $self->pointed_hint('upstream-metadata-missing-repository', $item->pointer)
+ if none { defined $yaml->{$_} } qw(Repository Repository-Browse);
+
+ $self->pointed_hint('upstream-metadata-missing-bug-tracking',
+ $item->pointer)
+ if none { defined $yaml->{$_} } qw(Bug-Database Bug-Submit);
+
+ return;
+}
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # here we check old upstream specification
+ # debian/upstream should be a directory
+ $self->pointed_hint('debian-upstream-obsolete-path', $item->pointer)
+ if $item->name eq 'debian/upstream'
+ || $item->name eq 'debian/upstream-metadata.yaml';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Upstream/SigningKey.pm b/lib/Lintian/Check/Debian/Upstream/SigningKey.pm
new file mode 100644
index 0000000..686966c
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Upstream/SigningKey.pm
@@ -0,0 +1,173 @@
+# debian/upstream/signing-key -- lintian check script -*- perl -*-
+
+# Copyright (C) 2018 Felix Lechner
+#
+# This program is free software. It is distributed under the terms of
+# the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any
+# later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Upstream::SigningKey;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use File::Temp;
+use List::Util qw(pairs);
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $SIGNING_KEY_FILENAMES
+ = $self->data->load('common/signing-key-filenames');
+
+ # Check all possible locations for signing keys
+ my %key_items;
+ for my $key_name ($SIGNING_KEY_FILENAMES->all) {
+ my $item
+ = $self->processable->patched->resolve_path("debian/$key_name");
+ $key_items{$key_name} = $item
+ if $item && $item->is_file;
+ }
+
+ # Check if more than one signing key is present
+ $self->hint('public-upstream-keys-in-multiple-locations',
+ (sort keys %key_items))
+ if scalar keys %key_items > 1;
+
+ # Go through signing keys and run checks for each
+ for my $key_name (sort keys %key_items) {
+
+ # native packages should not have such keys
+ if ($self->processable->native) {
+
+ $self->pointed_hint('public-upstream-key-in-native-package',
+ $key_items{$key_name}->pointer);
+ next;
+ }
+
+ # set up a temporary directory for gpg
+ my $tempdir = File::Temp->newdir();
+
+ # get keys packets from gpg
+ my @command = (
+ 'gpg', '--homedir',
+ $tempdir, '--batch',
+ '--attribute-fd', '1',
+ '--status-fd', '2',
+ '--with-colons', '--list-packets',
+ $key_items{$key_name}->unpacked_path
+ );
+ my $bytes = safe_qx(@command);
+
+ if ($?) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'cannot be processed'
+ );
+ next;
+ }
+
+ my $output = decode_utf8($bytes);
+
+ # remove comments
+ $output =~ s/^#[^\n]*$//mg;
+
+ # split into separate keys
+ my @keys = split(/^:public key packet:.*$/m, $output);
+
+ # discard leading information
+ shift @keys;
+
+ unless (scalar @keys) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'contains no keys'
+ );
+ next;
+ }
+
+ for my $key (@keys) {
+
+ # parse each key into separate packets
+ my ($public_key, @pieces) = split(/^(:.+)$/m, $key);
+ my @packets = pairs @pieces;
+
+ # require at least one packet
+ unless (length $public_key) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'has no public key'
+ );
+ next;
+ }
+
+ # look for key identifier
+ unless ($public_key =~ qr/^\s*keyid:\s+(\S+)$/m) {
+ $self->pointed_hint(
+ 'public-upstream-key-unusable',
+ $key_items{$key_name}->pointer,
+ 'has no keyid'
+ );
+ next;
+ }
+ my $keyid = $1;
+
+ # look for third-party signatures
+ my @thirdparty;
+ for my $packet (@packets) {
+
+ my $header = $packet->[0];
+ if ($header =~ qr/^:signature packet: algo \d+, keyid (\S*)$/){
+
+ my $signatory = $1;
+ push(@thirdparty, $signatory)
+ unless $signatory eq $keyid;
+ }
+ }
+
+ # signatures by parties other than self
+ my $extrasignatures = scalar @thirdparty;
+
+ # export-minimal strips such signatures
+ $self->pointed_hint(
+ 'public-upstream-key-not-minimal',
+ $key_items{$key_name}->pointer,
+ "has $extrasignatures extra signature(s) for keyid $keyid"
+ )if $extrasignatures;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Variables.pm b/lib/Lintian/Check/Debian/Variables.pm
new file mode 100644
index 0000000..31fa9a4
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Variables.pm
@@ -0,0 +1,60 @@
+# debian/variables -- lintian check script -*- perl -*-
+
+# Copyright (C) 2006 Russ Allbery <rra@debian.org>
+# Copyright (C) 2005 Rene van Bevern <rvb@pro-linux.de>
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+package Lintian::Check::Debian::Variables;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(none);
+
+const my @WANTED_FILES => (qr{ (.+ [.])? install }sx, qr{ (.+ [.])? links }sx);
+
+const my @ILLEGAL_VARIABLES => qw(DEB_BUILD_MULTIARCH);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^ debian/ }sx;
+
+ return
+ if none { $item->name =~ m{ / $_ $}sx } @WANTED_FILES;
+
+ for my $variable (@ILLEGAL_VARIABLES) {
+
+ $self->pointed_hint('illegal-variable', $item->pointer, $variable)
+ if $item->decoded_utf8 =~ m{ \b $variable \b }msx;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/VersionSubstvars.pm b/lib/Lintian/Check/Debian/VersionSubstvars.pm
new file mode 100644
index 0000000..e3789b8
--- /dev/null
+++ b/lib/Lintian/Check/Debian/VersionSubstvars.pm
@@ -0,0 +1,206 @@
+# debian/version-substvars -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2006 Adeodato Simo
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+# SUMMARY
+# =======
+#
+# What breaks
+# -----------
+#
+# (b1) any -> any (= ${source:Version}) -> use b:V
+# (b2) any -> all (= ${binary:Version}) [or S-V] -> use s:V
+# (b3) all -> any (= ${either-of-them}) -> use (>= ${s:V}),
+# optionally (<< ${s:V}.1~)
+#
+# Note (b2) also breaks if (>= ${binary:Version}) [or S-V] is used.
+#
+# Always warn on ${Source-Version} even if it doesn't break since the substvar
+# is now considered deprecated.
+
+package Lintian::Check::Debian::VersionSubstvars;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any uniq);
+
+use Lintian::Relation;
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $EQUAL => q{=};
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+
+ my @provides;
+ push(@provides,
+ $debian_control->installable_fields($_)
+ ->trimmed_list('Provides', qr/\s*,\s*/))
+ for $debian_control->installables;
+
+ for my $installable ($debian_control->installables) {
+
+ my $installable_control
+ = $debian_control->installable_fields($installable);
+
+ for my $field (
+ qw(Depends Pre-Depends Recommends Suggests Conflicts Replaces)) {
+
+ next
+ unless $installable_control->declares($field);
+
+ my $position = $installable_control->position($field);
+
+ my $relation
+ = $self->processable->binary_relation($installable, $field);
+
+ $self->pointed_hint(
+ 'substvar-source-version-is-deprecated',
+ $debian_control->item->pointer($position),
+ $installable, $field
+ )if $relation->matches(qr/\$[{]Source-Version[}]/);
+
+ my %external;
+ my $visitor = sub {
+ my ($value) = @_;
+
+ if (
+ $value
+ =~m{^($PKGNAME_REGEX)(?: :[-a-z0-9]+)? \s* # pkg-name $1
+ \(\s*[\>\<]?[=\>\<]\s* # REL
+ (\$[{](?:source:|binary:)(?:Upstream-)?Version[}]) # {subvar}
+ }x
+ ) {
+ my $other = $1;
+ my $substvar = $2;
+
+ $external{$substvar} //= [];
+ push(@{ $external{$substvar} }, $other);
+ }
+ };
+ $relation->visit($visitor, Lintian::Relation::VISIT_PRED_FULL);
+
+ for my $substvar (keys %external) {
+ for my $other (uniq @{ $external{$substvar} }) {
+
+ # We can't test dependencies on packages whose names are
+ # formed via substvars expanded during the build. Assume
+ # those maintainers know what they're doing.
+ $self->pointed_hint(
+ 'version-substvar-for-external-package',
+ $debian_control->item->pointer($position),
+ $field,
+ $substvar,
+ "$installable -> $other"
+ )
+ unless $debian_control->installable_fields($other)
+ ->declares('Architecture')
+ || (any { "$other (= $substvar)" eq $_ } @provides)
+ || $other =~ /\$\{\S+\}/;
+ }
+ }
+ }
+
+ my @pre_depends
+ = $installable_control->trimmed_list('Pre-Depends', qr/\s*,\s*/);
+ my @depends
+ = $installable_control->trimmed_list('Depends', qr/\s*,\s*/);
+
+ for my $versioned (uniq(@pre_depends, @depends)) {
+
+ next
+ unless $versioned
+ =~m{($PKGNAME_REGEX)(?: :any)? \s* # pkg-name
+ \(\s*([>]?=)\s* # rel
+ \$[{]((?:Source-|source:|binary:)Version)[}] # subvar
+ }x;
+
+ my $prerequisite = $1;
+ my $operator = $2;
+ my $substvar = $3;
+
+ my $prerequisite_control
+ = $debian_control->installable_fields($prerequisite);
+
+ # external relation or subst var package; handled above
+ next
+ unless $prerequisite_control->declares('Architecture');
+
+ my $prerequisite_is_all
+ = ($prerequisite_control->value('Architecture') eq 'all');
+ my $installable_is_all
+ = ($installable_control->value('Architecture') eq 'all');
+
+ my $context = "$installable -> $prerequisite";
+
+ # (b1) any -> any (= ${source:Version})
+ $self->hint('not-binnmuable-any-depends-any', $context)
+ if !$installable_is_all
+ && !$prerequisite_is_all
+ && $operator eq $EQUAL
+ && $substvar eq 'source:Version';
+
+ # (b2) any -> all (= ${binary:Version}) [or S-V]
+ $self->hint('maybe-not-arch-all-binnmuable', $context)
+ if !$installable_is_all
+ && $prerequisite_is_all
+ && $operator eq $EQUAL
+ && $substvar eq 'source:Version';
+
+ # (b2) any -> all (* ${binary:Version}) [or S-V]
+ $self->hint('not-binnmuable-any-depends-all', $context)
+ if !$installable_is_all
+ && $prerequisite_is_all
+ && $substvar ne 'source:Version';
+
+ # (b3) all -> any (= ${either-of-them})
+ $self->hint('not-binnmuable-all-depends-any', $context)
+ if $installable_is_all
+ && !$prerequisite_is_all
+ && $operator eq $EQUAL;
+
+ # any -> any (>= ${source:Version})
+ # technically this can be "binNMU'ed", though it is
+ # a bit weird.
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Watch.pm b/lib/Lintian/Check/Debian/Watch.pm
new file mode 100644
index 0000000..2f891d3
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Watch.pm
@@ -0,0 +1,379 @@
+# debian/watch -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2008 Patrick Schoenfeld
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2008 Raphael Geissert
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Watch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any firstval firstres);
+use Path::Tiny;
+
+use Lintian::Util qw($PKGREPACK_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+const my $URL_ACTION_FIELDS => 4;
+const my $VERSION_ACTION_FIELDS => 3;
+
+const my $DMANGLES_AUTOMATICALLY => 4;
+
+sub source {
+ my ($self) = @_;
+
+ my $item = $self->processable->patched->resolve_path('debian/watch');
+ unless ($item && $item->is_file) {
+
+ $self->hint('debian-watch-file-is-missing')
+ unless $self->processable->native;
+
+ return;
+ }
+
+ # Perform the other checks even if it is a native package
+ $self->pointed_hint('debian-watch-file-in-native-package', $item->pointer)
+ if $self->processable->native;
+
+ # Check if the Debian version contains anything that resembles a repackaged
+ # source package sign, for fine grained version mangling check
+ # If the version field is missing, we assume a neutral non-native one.
+
+ # upstream method returns empty for native packages
+ my $upstream = $self->processable->changelog_version->upstream;
+ my ($prerelease) = ($upstream =~ qr/(alpha|beta|rc)/i);
+
+# there is a good repack indicator in $processable->repacked but we need the text
+ my ($repack) = ($upstream =~ $PKGREPACK_REGEX);
+
+ return
+ unless $item->is_open_ok;
+
+ my $contents = $item->bytes;
+
+ # each pattern marks a multi-line (!) selection for the tag message
+ my @templatepatterns
+ = (qr/^\s*#\s*(Example watch control file for uscan)/mi,qr/(<project>)/);
+ my $templatestring;
+
+ for my $pattern (@templatepatterns) {
+ ($templatestring) = ($contents =~ $pattern);
+ last if defined $templatestring;
+ }
+
+ $self->pointed_hint('debian-watch-contains-dh_make-template',
+ $item->pointer, $templatestring)
+ if length $templatestring;
+
+ # remove backslash at end; uscan will catch it
+ $contents =~ s/(?<!\\)\\$//;
+
+ my $standard;
+
+ my @lines = split(/\n/, $contents);
+
+ # look for watch file version
+ for my $line (@lines) {
+
+ if ($line =~ /^\s*version\s*=\s*(\d+)\s*$/) {
+ if (length $1) {
+ $standard = $1;
+ last;
+ }
+ }
+ }
+
+ return
+ unless defined $standard;
+
+ # version 1 too broken to check
+ return
+ if $standard < 2;
+
+ # allow spaces for all watch file versions (#950250, #950277)
+ my $separator = qr/\s*,\s*/;
+
+ my $withpgpverification = 0;
+ my %dversions;
+
+ my $position = 1;
+ my $continued = $EMPTY;
+ for my $line (@lines) {
+
+ my $pointer = $item->pointer($position);
+
+ # strip leading spaces
+ $line =~ s/^\s*//;
+
+ # strip comments, if any
+ $line =~ s/^\#.*$//;
+
+ unless (length $line) {
+ $continued = $EMPTY;
+ next;
+ }
+
+ # merge continuation lines
+ if ($line =~ s/\\$//) {
+ $continued .= $line;
+ next;
+ }
+
+ $line = $continued . $line
+ if length $continued;
+
+ $continued = $EMPTY;
+
+ next
+ if $line =~ /^version\s*=\s*\d+\s*$/;
+
+ my $remainder = $line;
+
+ my @options;
+
+ # keep order; otherwise. alternative \S+ ends up with quotes
+ if ($remainder =~ s/opt(?:ion)?s=(?|\"((?:[^\"]|\\\")+)\"|(\S+))\s+//){
+ @options = split($separator, $1);
+ }
+
+ unless (length $remainder) {
+
+ $self->pointed_hint('debian-watch-line-invalid', $pointer, $line);
+ next;
+ }
+
+ my $repack_mangle = 0;
+ my $repack_dmangle = 0;
+ my $repack_dmangle_auto = 0;
+ my $prerelease_mangle = 0;
+ my $prerelease_umangle = 0;
+
+ for my $option (@options) {
+
+ if (length $repack) {
+ $repack_mangle = 1
+ if $option
+ =~ /^[ud]?versionmangle\s*=\s*(?:auto|.*$repack.*)/;
+ $repack_dmangle = 1
+ if $option =~ /^dversionmangle\s*=\s*(?:auto|.*$repack.*)/;
+ }
+
+ if (length $prerelease) {
+ $prerelease_mangle = 1
+ if $option =~ /^[ud]?versionmangle\s*=.*$prerelease/;
+ $prerelease_umangle = 1
+ if $option =~ /^uversionmangle\s*=.*$prerelease/;
+ }
+
+ $repack_dmangle_auto = 1
+ if $option =~ /^dversionmangle\s*=.*(?:s\/\@DEB_EXT\@\/|auto)/
+ && $standard >= $DMANGLES_AUTOMATICALLY;
+
+ $withpgpverification = 1
+ if $option =~ /^pgpsigurlmangle\s*=\s*/
+ || $option =~ /^pgpmode\s*=\s*(?!none\s*$)\S.*$/;
+
+ my ($name, $value) = split(m{ \s* = \s* }x, $option, 2);
+
+ next
+ unless length $name;
+
+ $value //= $EMPTY;
+
+ $self->pointed_hint('prefer-uscan-symlink',$pointer, $name, $value)
+ if $name eq 'filenamemangle';
+ }
+
+ $self->pointed_hint(
+ 'debian-watch-file-uses-deprecated-sf-redirector-method',
+ $pointer,$remainder)
+ if $remainder =~ m{qa\.debian\.org/watch/sf\.php\?};
+
+ $self->pointed_hint('debian-watch-file-uses-deprecated-githubredir',
+ $pointer, $remainder)
+ if $remainder =~ m{githubredir\.debian\.net};
+
+ $self->pointed_hint('debian-watch-lacks-sourceforge-redirector',
+ $pointer, $remainder)
+ if $remainder =~ m{ (?:https?|ftp)://
+ (?:(?:.+\.)?dl|(?:pr)?downloads?|ftp\d?|upload) \.
+ (?:sourceforge|sf)\.net}xsm
+ || $remainder =~ m{https?://(?:www\.)?(?:sourceforge|sf)\.net
+ /project/showfiles\.php}xsm
+ || $remainder =~ m{https?://(?:www\.)?(?:sourceforge|sf)\.net
+ /projects/.+/files}xsm;
+
+ if ($remainder =~ m{((?:http|ftp):(?!//sf.net/)\S+)}) {
+ $self->pointed_hint('debian-watch-uses-insecure-uri', $pointer,$1);
+ }
+
+ # This bit is as-is from uscan.pl:
+ my ($base, $filepattern, $lastversion, $action)
+ = split($SPACE, $remainder, $URL_ACTION_FIELDS);
+
+ # Per #765995, $base might be undefined.
+ if (defined $base) {
+ if ($base =~ s{/([^/]*\([^/]*\)[^/]*)$}{/}) {
+ # Last component of $base has a pair of parentheses, so no
+ # separate filepattern field; we remove the filepattern from the
+ # end of $base and rescan the rest of the line
+ $filepattern = $1;
+ (undef, $lastversion, $action)
+ = split($SPACE, $remainder, $VERSION_ACTION_FIELDS);
+ }
+
+ $dversions{$lastversion} = 1
+ if defined $lastversion;
+
+ $lastversion = 'debian'
+ unless defined $lastversion;
+ }
+
+ # If the version of the package contains dfsg, assume that it needs
+ # to be mangled to get reasonable matches with upstream.
+ my $needs_repack_mangling = ($repack && $lastversion eq 'debian');
+
+ $self->pointed_hint('debian-watch-not-mangling-version',
+ $pointer, $line)
+ if $needs_repack_mangling
+ && !$repack_mangle
+ && !$repack_dmangle_auto;
+
+ $self->pointed_hint('debian-watch-mangles-debian-version-improperly',
+ $pointer, $line)
+ if $needs_repack_mangling
+ && $repack_mangle
+ && !$repack_dmangle;
+
+ my $needs_prerelease_mangling
+ = ($prerelease && $lastversion eq 'debian');
+
+ $self->pointed_hint('debian-watch-mangles-upstream-version-improperly',
+ $pointer, $line)
+ if $needs_prerelease_mangling
+ && $prerelease_mangle
+ && !$prerelease_umangle;
+
+ my $upstream_url = $remainder;
+
+ # Keep only URL part
+ $upstream_url =~ s/(.*?\S)\s.*$/$1/;
+
+ for my $option (@options) {
+ if ($option =~ /^ component = (.+) $/x) {
+
+ my $component = $1;
+
+ $self->pointed_hint('debian-watch-upstream-component',
+ $pointer, $upstream_url, $component);
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ $self->pointed_hint('debian-watch-does-not-check-openpgp-signature',
+ $item->pointer)
+ unless $withpgpverification;
+
+ my $SIGNING_KEY_FILENAMES
+ = $self->data->load('common/signing-key-filenames');
+
+ # look for upstream signing key
+ my @candidates
+ = map { $self->processable->patched->resolve_path("debian/$_") }
+ $SIGNING_KEY_FILENAMES->all;
+ my $keyfile = firstval {$_ && $_->is_file} @candidates;
+
+ # check upstream key is present if needed
+ $self->pointed_hint('debian-watch-file-pubkey-file-is-missing',
+ $item->pointer)
+ if $withpgpverification && !$keyfile;
+
+ # check upstream key is used if present
+ $self->pointed_hint('debian-watch-could-verify-download',
+ $item->pointer, $keyfile->name)
+ if $keyfile && !$withpgpverification;
+
+ if (defined $self->processable->changelog && %dversions) {
+
+ my %changelog_versions;
+ my $count = 1;
+ my $changelog = $self->processable->changelog;
+ for my $entry (@{$changelog->entries}) {
+ my $uversion = $entry->Version;
+ $uversion =~ s/-[^-]+$//; # revision
+ $uversion =~ s/^\d+://; # epoch
+ $changelog_versions{'orig'}{$entry->Version} = $count;
+
+ # Preserve the first value here to correctly detect old versions.
+ $changelog_versions{'mangled'}{$uversion} = $count
+ unless (exists($changelog_versions{'mangled'}{$uversion}));
+ $count++;
+ }
+
+ for my $dversion (sort keys %dversions) {
+
+ next
+ if $dversion eq 'debian';
+
+ local $" = ', ';
+
+ if (!$self->processable->native
+ && exists($changelog_versions{'orig'}{$dversion})) {
+
+ $self->pointed_hint(
+ 'debian-watch-file-specifies-wrong-upstream-version',
+ $item->pointer, $dversion);
+ next;
+ }
+
+ if (exists $changelog_versions{'mangled'}{$dversion}
+ && $changelog_versions{'mangled'}{$dversion} != 1) {
+
+ $self->pointed_hint(
+ 'debian-watch-file-specifies-old-upstream-version',
+ $item->pointer, $dversion);
+ next;
+ }
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debian/Watch/Standard.pm b/lib/Lintian/Check/Debian/Watch/Standard.pm
new file mode 100644
index 0000000..129966d
--- /dev/null
+++ b/lib/Lintian/Check/Debian/Watch/Standard.pm
@@ -0,0 +1,98 @@
+# debian/watch/standard -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debian::Watch::Standard;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::Util qw(max);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+const my @STANDARDS => (2, 3, 4);
+const my $NEWLY_SUPERSEEDED => 3;
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'debian/watch';
+
+ my $contents = $item->bytes;
+ return
+ unless length $contents;
+
+ # look for version
+ my @mentioned = ($contents =~ /^ version \s* = \s* (\d+) \s* $/gmsx);
+
+ my $has_contents = !!($contents =~ m{^ \s* [^#] }gmx);
+
+ if ($has_contents && !@mentioned) {
+
+ $self->pointed_hint('missing-debian-watch-file-standard',
+ $item->pointer);
+ return;
+ }
+
+ $self->pointed_hint('multiple-debian-watch-file-standards',
+ $item->pointer,join($SPACE, @mentioned))
+ if @mentioned > 1;
+
+ my $standard_lc = List::Compare->new(\@mentioned, \@STANDARDS);
+ my @unknown = $standard_lc->get_Lonly;
+ my @known = $standard_lc->get_intersection;
+
+ $self->pointed_hint('unknown-debian-watch-file-standard',
+ $item->pointer, $_)
+ for @unknown;
+
+ return
+ unless @known;
+
+ my $highest = max(@known);
+ $self->pointed_hint('debian-watch-file-standard', $item->pointer,$highest);
+
+ $self->pointed_hint('older-debian-watch-file-standard',
+ $item->pointer, $highest)
+ if $highest == $NEWLY_SUPERSEEDED;
+
+ $self->pointed_hint('obsolete-debian-watch-file-standard',
+ $item->pointer, $highest)
+ if $highest < $NEWLY_SUPERSEEDED;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debug/Automatic.pm b/lib/Lintian/Check/Debug/Automatic.pm
new file mode 100644
index 0000000..1bb803f
--- /dev/null
+++ b/lib/Lintian/Check/Debug/Automatic.pm
@@ -0,0 +1,63 @@
+# debug/automatic -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debug::Automatic;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $field = 'Package';
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'debian-control-has-dbgsym-package',$pointer,
+ "(in section for $installable)", $field
+ )if $installable =~ m{ [-] dbgsym $}x;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Debug/Obsolete.pm b/lib/Lintian/Check/Debug/Obsolete.pm
new file mode 100644
index 0000000..77e9bba
--- /dev/null
+++ b/lib/Lintian/Check/Debug/Obsolete.pm
@@ -0,0 +1,70 @@
+# debug/obsolete -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Debug::Obsolete;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my $KNOWN_LEGACY_DBG_PATTERNS= $self->data->load('common/dbg-pkg');
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $field = 'Package';
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'debian-control-has-obsolete-dbg-package',$pointer,
+ "(in section for $installable)", $field
+ )
+ if $installable =~ m{ [-] dbg $}x
+ && (none { $installable =~ m{$_}xms }
+ $KNOWN_LEGACY_DBG_PATTERNS->all);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Desktop/Dbus.pm b/lib/Lintian/Check/Desktop/Dbus.pm
new file mode 100644
index 0000000..31d1f79
--- /dev/null
+++ b/lib/Lintian/Check/Desktop/Dbus.pm
@@ -0,0 +1,189 @@
+# desktop/dbus -- lintian check script, vaguely based on apache2 -*- perl -*-
+#
+# Copyright (C) 2012 Arno Toell
+# Copyright (C) 2014 Collabora Ltd.
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Desktop::Dbus;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::UtilsBy qw(uniq_by);
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ my $index = $self->processable->installed;
+
+ my @files;
+ for my $prefix (qw(etc/dbus-1 usr/share/dbus-1)) {
+ for my $suffix (qw(session system)) {
+
+ my $folder = $index->resolve_path("${prefix}/${suffix}.d");
+ next
+ unless defined $folder;
+
+ push(@files, $folder->children);
+ }
+ }
+
+ my @unique = uniq_by { $_->name } @files;
+
+ $self->check_policy($_) for @unique;
+
+ if (my $folder= $index->resolve_path('usr/share/dbus-1/services')) {
+
+ $self->check_service($_, session => 1) for $folder->children;
+ }
+
+ if (my $folder= $index->resolve_path('usr/share/dbus-1/system-services')) {
+ $self->check_service($_) for $folder->children;
+ }
+
+ return;
+}
+
+my $PROPERTIES = 'org.freedesktop.DBus.Properties';
+
+sub check_policy {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('dbus-policy-in-etc', $item->pointer)
+ if $item->name =~ m{^etc/};
+
+ my $xml = $item->decoded_utf8;
+ return
+ unless length $xml;
+
+ # Parsing XML via regexes is evil, but good enough here...
+ # note that we are parsing the entire file as one big string,
+ # so that we catch <policy\nat_console="true"\n> or whatever.
+
+ my @rules;
+ # a small rubbish state machine: we want to match a <policy> containing
+ # any <allow> or <deny> rule that is about sending
+ my $policy = $EMPTY;
+ while ($xml =~ m{(<policy[^>]*>)|(</policy\s*>)|(<(?:allow|deny)[^>]*>)}sg)
+ {
+ if (defined $1) {
+ $policy = $1;
+
+ } elsif (defined $2) {
+ $policy = $EMPTY;
+
+ } else {
+ push(@rules, $policy.$3);
+ }
+ }
+
+ my $position = 1;
+ for my $rule (@rules) {
+ # normalize whitespace a bit so we can report it sensibly:
+ # typically it will now look like
+ # <policy context="default"><allow send_destination="com.example.Foo"/>
+ $rule =~ s{\s+}{ }g;
+
+ if ($rule =~ m{send_} && $rule !~ m{send_destination=}) {
+ # It is about sending but does not specify a send-destination.
+ # This could be bad.
+
+ if ($rule =~ m{[^>]*user=['"]root['"].*<allow}) {
+ # skip it: it's probably the "agent" pattern (as seen in
+ # e.g. BlueZ), and cannot normally be a security flaw
+ # because root can do anything anyway
+
+ } else {
+ $self->pointed_hint('dbus-policy-without-send-destination',
+ $item->pointer($position), $rule);
+
+ if ( $rule =~ m{send_interface=}
+ && $rule !~ m{send_interface=['"]\Q${PROPERTIES}\E['"]}) {
+ # That's undesirable, because it opens up communication
+ # with arbitrary services and can undo DoS mitigation
+ # efforts; but at least it's specific to an interface
+ # other than o.fd.DBus.Properties, so all that should
+ # happen is that the service sends back an error message.
+ #
+ # Properties doesn't count as an effective limitation,
+ # because it's a sort of meta-interface.
+
+ } elsif ($rule =~ m{<allow}) {
+ # Looks like CVE-2014-8148 or similar. This is really bad;
+ # emit an additional tag.
+ $self->pointed_hint('dbus-policy-excessively-broad',
+ $item->pointer($position), $rule);
+ }
+ }
+ }
+
+ $self->pointed_hint('dbus-policy-at-console',
+ $item->pointer($position), $rule)
+ if $rule =~ m{at_console=['"]true};
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+sub check_service {
+ my ($self, $item, %kwargs) = @_;
+
+ my $text = $item->decoded_utf8;
+ return
+ unless length $text;
+
+ while ($text =~ m{^Name=(.*)$}gm) {
+
+ my $name = $1;
+
+ next
+ if $item->basename eq "${name}.service";
+
+ if ($kwargs{session}) {
+ $self->pointed_hint('dbus-session-service-wrong-name',
+ $item->pointer,"better: ${name}.service");
+
+ } else {
+ $self->pointed_hint('dbus-system-service-wrong-name',
+ $item->pointer, "better: ${name}.service");
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Desktop/Gnome.pm b/lib/Lintian/Check/Desktop/Gnome.pm
new file mode 100644
index 0000000..16bb0d1
--- /dev/null
+++ b/lib/Lintian/Check/Desktop/Gnome.pm
@@ -0,0 +1,49 @@
+# desktop/gnome -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Desktop::Gnome;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # /etc/gconf/schemas
+ $self->pointed_hint('package-installs-into-etc-gconf-schemas',
+ $item->pointer)
+ if $item->name =~ m{^etc/gconf/schemas/\S};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Desktop/Gnome/Gir.pm b/lib/Lintian/Check/Desktop/Gnome/Gir.pm
new file mode 100644
index 0000000..6f18594
--- /dev/null
+++ b/lib/Lintian/Check/Desktop/Gnome/Gir.pm
@@ -0,0 +1,166 @@
+# desktop/gnome/gir -- lintian check script for GObject-Introspection -*- perl -*-
+#
+# Copyright (C) 2012 Arno Toell
+# Copyright (C) 2014 Collabora Ltd.
+# Copyright (C) 2016 Simon McVittie
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Desktop::Gnome::Gir;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $DOLLAR => q{$};
+
+const my $NONE => q{NONE};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+
+ for my $installable ($debian_control->installables) {
+
+ $self->pointed_hint('typelib-missing-gir-depends',
+ $debian_control->item->pointer, $installable)
+ if $installable =~ m/^gir1\.2-/
+ && !$self->processable->binary_relation($installable, 'strong')
+ ->satisfies($DOLLAR . '{gir:Depends}');
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch;
+ my $triplet = $DEB_HOST_MULTIARCH->{$self->processable->architecture};
+
+ # Slightly contrived, but it might be Architecture: all, in which
+ # case this is the best we can do
+ $triplet = $DOLLAR . '{DEB_HOST_MULTIARCH}'
+ unless defined $triplet;
+
+ my $xml_dir
+ = $self->processable->installed->resolve_path('usr/share/gir-1.0/');
+
+ my @girs;
+ @girs = grep { $_->name =~ m{ [.]gir $}x } $xml_dir->children
+ if defined $xml_dir;
+
+ my @type_libs;
+
+ my $old_dir
+ = $self->processable->installed->resolve_path(
+ 'usr/lib/girepository-1.0/');
+
+ if (defined $old_dir) {
+
+ $self->pointed_hint('typelib-not-in-multiarch-directory',
+ $_->pointer,"usr/lib/$triplet/girepository-1.0")
+ for $old_dir->children;
+
+ push(@type_libs, $old_dir->children);
+ }
+
+ my $multiarch_dir= $self->processable->installed->resolve_path(
+ "usr/lib/$triplet/girepository-1.0");
+ push(@type_libs, $multiarch_dir->children)
+ if defined $multiarch_dir;
+
+ my $section = $self->processable->fields->value('Section');
+ if ($section ne 'libdevel' && $section ne 'oldlibs') {
+
+ $self->pointed_hint('gir-section-not-libdevel', $_->pointer,
+ $section || $NONE)
+ for @girs;
+ }
+
+ if ($section ne 'introspection' && $section ne 'oldlibs') {
+
+ $self->pointed_hint('typelib-section-not-introspection',
+ $_->pointer, $section || $NONE)
+ for @type_libs;
+ }
+
+ if ($self->processable->architecture eq 'all') {
+
+ $self->pointed_hint('gir-in-arch-all-package', $_->pointer)for @girs;
+
+ $self->pointed_hint('typelib-in-arch-all-package', $_->pointer)
+ for @type_libs;
+ }
+
+ GIR: for my $gir (@girs) {
+
+ my $expected = 'gir1.2-' . lc($gir->basename);
+ $expected =~ s/\.gir$//;
+ $expected =~ tr/_/-/;
+
+ for my $installable ($self->group->get_installables) {
+ next
+ unless $installable->name =~ m/^gir1\.2-/;
+
+ my $name = $installable->name;
+ my $version = $installable->fields->value('Version');
+
+ next GIR
+ if $installable->relation('Provides')->satisfies($expected)
+ && $self->processable->relation('strong')
+ ->satisfies("$name (= $version)");
+ }
+
+ my $our_version = $self->processable->fields->value('Version');
+
+ $self->pointed_hint('gir-missing-typelib-dependency',
+ $gir->pointer, $expected)
+ unless $self->processable->relation('strong')
+ ->satisfies("$expected (= $our_version)");
+ }
+
+ for my $type_lib (@type_libs) {
+
+ my $expected = 'gir1.2-' . lc($type_lib->basename);
+ $expected =~ s/\.typelib$//;
+ $expected =~ tr/_/-/;
+
+ $self->pointed_hint('typelib-package-name-does-not-match',
+ $type_lib->pointer, $expected)
+ if $self->processable->name ne $expected
+ && !$self->processable->relation('Provides')->satisfies($expected);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm b/lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm
new file mode 100644
index 0000000..d667717
--- /dev/null
+++ b/lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm
@@ -0,0 +1,65 @@
+# desktop/gnome/gir/substvars -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Desktop::Gnome::Gir::Substvars;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $DOLLAR => q{$};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+
+ for my $installable ($debian_control->installables) {
+
+ next
+ unless $installable =~ m{ gir [\d.]+ - .* - [\d.]+ $}x;
+
+ my $relation= $self->processable->binary_relation($installable, 'all');
+
+ $self->pointed_hint(
+ 'gobject-introspection-package-missing-depends-on-gir-depends',
+ $debian_control->item->pointer,$installable)
+ unless $relation->satisfies($DOLLAR . '{gir:Depends}');
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Desktop/Icons.pm b/lib/Lintian/Check/Desktop/Icons.pm
new file mode 100644
index 0000000..95565ed
--- /dev/null
+++ b/lib/Lintian/Check/Desktop/Icons.pm
@@ -0,0 +1,69 @@
+# desktop/icons -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Desktop::Icons;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->name =~ m{/icons/[^/]+/(\d+)x(\d+)/(?!animations/).*\.png$}){
+
+ my $directory_width = $1;
+ my $directory_height = $2;
+
+ my $resolved = $item->resolve_path;
+
+ if ($resolved && $resolved->file_type =~ m/,\s*(\d+)\s*x\s*(\d+)\s*,/){
+
+ my $file_width = $1;
+ my $file_height = $2;
+
+ my $width_delta = abs($directory_width - $file_width);
+ my $height_delta = abs($directory_height - $file_height);
+
+ $self->pointed_hint('icon-size-and-directory-name-mismatch',
+ $item->pointer, $file_width.'x'.$file_height)
+ if $width_delta > 2 || $height_delta > 2;
+ }
+ }
+
+ $self->pointed_hint('raster-image-in-scalable-directory', $item->pointer)
+ if $item->is_file
+ && $item->name =~ m{/icons/[^/]+/scalable/.*\.(?:png|xpm)$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Desktop/X11.pm b/lib/Lintian/Check/Desktop/X11.pm
new file mode 100644
index 0000000..4373980
--- /dev/null
+++ b/lib/Lintian/Check/Desktop/X11.pm
@@ -0,0 +1,94 @@
+# desktop/x11 -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Desktop::X11;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has fontdirs => (is => 'rw', default => sub { {} });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # links to FHS locations are allowed
+ $self->pointed_hint('package-installs-file-to-usr-x11r6', $item->pointer)
+ if $item->name =~ m{^usr/X11R6/} && !$item->is_symlink;
+
+ return
+ if $item->is_dir;
+
+ # /usr/share/fonts/X11
+ my ($subdir) = ($item->name =~ m{^usr/share/fonts/X11/([^/]+)/\S+});
+ if (defined $subdir) {
+
+ $self->fontdirs->{$subdir}++
+ if any { $subdir eq $_ } qw(100dpi 75dpi misc);
+
+ if (any { $subdir eq $_ } qw(PEX CID Speedo cyrillic)) {
+ $self->pointed_hint('file-in-discouraged-x11-font-directory',
+ $item->pointer);
+
+ } elsif (none { $subdir eq $_ }
+ qw(100dpi 75dpi misc Type1 encodings util)) {
+ $self->pointed_hint('file-in-unknown-x11-font-directory',
+ $item->pointer);
+
+ } elsif ($item->basename eq 'encodings.dir'
+ or $item->basename =~ m{fonts\.(dir|scale|alias)}) {
+ $self->pointed_hint('package-contains-compiled-font-file',
+ $item->pointer);
+ }
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ # X11 font directories with files
+ my %fontdirs = %{$self->fontdirs};
+
+ # check for multiple DPIs in the same X11 bitmap font package.
+ $self->hint('package-contains-multiple-dpi-fonts')
+ if $fontdirs{'100dpi'} && $fontdirs{'75dpi'};
+
+ $self->hint('package-mixes-misc-and-dpi-fonts')
+ if $fontdirs{misc} && keys %fontdirs > 1;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Desktop/X11/Font/Update.pm b/lib/Lintian/Check/Desktop/X11/Font/Update.pm
new file mode 100644
index 0000000..2315e7d
--- /dev/null
+++ b/lib/Lintian/Check/Desktop/X11/Font/Update.pm
@@ -0,0 +1,159 @@
+# desktop/x11/font/update -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Desktop::X11::Font::Update;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# When detecting commands inside shell scripts, use this regex to match the
+# beginning of the command rather than checking whether the command is at the
+# beginning of a line.
+const my $LEADING_PATTERN=>
+'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
+const my $LEADING_REGEX => qr/$LEADING_PATTERN/;
+
+has x_fonts => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @x_fonts
+ = grep { m{^usr/share/fonts/X11/.*\.(?:afm|pcf|pfa|pfb)(?:\.gz)?$} }
+ @{$self->processable->installed->sorted_list};
+
+ return \@x_fonts;
+ }
+);
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $saw_update_fonts = 0;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ $saw_update_fonts = 1
+ if $line
+ =~ m{$LEADING_REGEX(?:/usr/bin/)?update-fonts-(?:alias|dir|scale)\s(\S+)};
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ if ($item->name eq 'postinst' && !$saw_update_fonts) {
+
+ $self->pointed_hint('missing-call-to-update-fonts', $item->pointer, $_)
+ for @{$self->x_fonts};
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/DhMake.pm b/lib/Lintian/Check/DhMake.pm
new file mode 100644
index 0000000..42f8d94
--- /dev/null
+++ b/lib/Lintian/Check/DhMake.pm
@@ -0,0 +1,83 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::DhMake;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('readme-source-is-dh_make-template', $item->pointer)
+ if $item->name eq 'debian/README.source'
+ && $item->bytes
+ =~ / \QYou WILL either need to modify or delete this file\E /isx;
+
+ if ( $item->name =~ m{^debian/(README.source|copyright|rules|control)$}
+ && $item->is_open_ok) {
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ unless $line =~ m/(?<!")(FIX_?ME)(?!")/;
+
+ my $placeholder = $1;
+
+ $self->pointed_hint('file-contains-fixme-placeholder',
+ $item->pointer($position), $placeholder);
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/DhMake/Template.pm b/lib/Lintian/Check/DhMake/Template.pm
new file mode 100644
index 0000000..64c1f57
--- /dev/null
+++ b/lib/Lintian/Check/DhMake/Template.pm
@@ -0,0 +1,52 @@
+# dh-make/template -- lintian check script -*- perl -*-
+
+# Copyright (C) 1999 by Joey Hess
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::DhMake::Template;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->dirname eq 'debian/';
+
+ $self->pointed_hint('dh-make-template-in-source', $item->pointer)
+ if $item->basename =~ m{^ ex[.] | [.]ex $}ix;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Documentation.pm b/lib/Lintian/Check/Documentation.pm
new file mode 100644
index 0000000..364ecde
--- /dev/null
+++ b/lib/Lintian/Check/Documentation.pm
@@ -0,0 +1,246 @@
+# documentation -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Documentation;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $VERTICAL_BAR => q{|};
+
+# 276 is 255 bytes (maximal length for a filename) plus gzip overhead
+const my $MAXIMUM_EMPTY_GZIP_SIZE => 276;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# a list of regex for detecting non documentation files checked against basename (xi)
+my @NOT_DOCUMENTATION_FILE_REGEXES = qw{
+ ^dependency_links[.]txt$
+ ^entry_points[.]txt$
+ ^requires[.]txt$
+ ^top_level[.]txt$
+ ^requirements[.]txt$
+ ^namespace_packages[.]txt$
+ ^bindep[.]txt$
+ ^version[.]txt$
+ ^robots[.]txt$
+ ^cmakelists[.]txt$
+};
+
+# a list of regex for detecting documentation file checked against basename (xi)
+my @DOCUMENTATION_FILE_REGEXES = qw{
+ [.]docx?$
+ [.]html?$
+ [.]info$
+ [.]latex$
+ [.]markdown$
+ [.]md$
+ [.]odt$
+ [.]pdf$
+ [.]readme$
+ [.]rmd$
+ [.]rst$
+ [.]rtf$
+ [.]tex$
+ [.]txt$
+ ^code[-_]of[-_]conduct$
+ ^contribut(?:e|ing)$
+ ^copyright$
+ ^licen[sc]es?$
+ ^howto$
+ ^patents?$
+ ^readme(?:[.]?first|[.]1st|[.]debian|[.]source)?$
+ ^todos?$
+};
+
+# an OR (|) regex of all compressed extension
+has COMPRESS_FILE_EXTENSIONS_OR_ALL => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $COMPRESS_FILE_EXTENSIONS
+ = $self->data->load('files/compressed-file-extensions',qr/\s+/);
+
+ my $text = join($VERTICAL_BAR,
+ (map { quotemeta } $COMPRESS_FILE_EXTENSIONS->all));
+
+ return qr/$text/;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $ppkg = quotemeta($self->processable->name);
+
+ if ( $self->processable->type eq 'udeb'
+ && $item->name =~ m{^usr/share/(?:doc|info)/\S}) {
+
+ $self->pointed_hint('udeb-contains-documentation-file',$item->pointer);
+ return;
+ }
+
+ $self->pointed_hint('package-contains-info-dir-file', $item->pointer)
+ if $item->name =~ m{^ usr/share/info/dir (?:[.]old)? (?:[.]gz)? $}x;
+
+ # doxygen md5sum
+ $self->pointed_hint('useless-autogenerated-doxygen-file', $item->pointer)
+ if $item->name =~ m{^ usr/share/doc/ $ppkg / [^/]+ / .+ [.]md5$ }sx
+ && $item->parent_dir->child('doxygen.png');
+
+ my $regex = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL;
+
+ # doxygen compressed map
+ $self->pointed_hint('compressed-documentation', $item->pointer)
+ if $item->name
+ =~ m{^ usr/share/doc/ (?:.+/)? (?:doxygen|html) / .* [.]map [.] $regex }sx;
+
+ if ($item->is_file
+ and any { $item->basename =~ m{$_}xi } @DOCUMENTATION_FILE_REGEXES
+ and any { $item->basename !~ m{$_}xi } @NOT_DOCUMENTATION_FILE_REGEXES)
+ {
+
+ $self->pointed_hint(
+ 'package-contains-documentation-outside-usr-share-doc',
+ $item->pointer)
+ unless $item->name =~ m{^etc/}
+ || $item->name =~ m{^usr/share/(?:doc|help)/}
+ # see Bug#981268
+ # usr/lib/python3/dist-packages/*.dist-info/entry_points.txt
+ || $item->name =~ m{^ usr/lib/python3/dist-packages/
+ .+ [.] dist-info/entry_points.txt $}sx
+ # No need for dh-r packages to automatically
+ # create overrides if we just allow them all to
+ # begin with.
+ || $item->dirname =~ 'usr/lib/R/site-library/'
+ # SNMP MIB files, see Bug#971427
+ || $item->dirname eq 'usr/share/snmp/mibs/'
+ # see Bug#904852
+ || $item->dirname =~ m{templates?(?:[.]d)?/}
+ || ( $item->basename =~ m{^README}xi
+ && $item->bytes =~ m{this directory}xi)
+ # see Bug#1009679, not documentation, just an unlucky suffix
+ || $item->name =~ m{^var/lib/ocaml/lintian/.+[.]info$}
+ # see Bug#970275
+ || $item->name =~ m{^usr/share/gtk-doc/html/.+[.]html?$};
+ }
+
+ if ($item->name =~ m{^usr/share/doc/\S}) {
+
+ # file not owned by root?
+ unless ($item->identity eq 'root/root' || $item->identity eq '0/0') {
+ $self->pointed_hint('bad-owner-for-doc-file', $item->pointer,
+ $item->identity,'!= root/root (or 0/0)');
+ }
+
+ # executable in /usr/share/doc ?
+ if ( $item->is_file
+ && $item->name !~ m{^usr/share/doc/(?:[^/]+/)?examples/}
+ && $item->is_executable) {
+
+ if ($item->is_script) {
+ $self->pointed_hint('script-in-usr-share-doc', $item->pointer);
+ } else {
+ $self->pointed_hint('executable-in-usr-share-doc',
+ $item->pointer,(sprintf '%04o', $item->operm));
+ }
+ }
+
+ # zero byte file in /usr/share/doc/
+ if ($item->is_regular_file and $item->size == 0) {
+ # Exceptions: examples may contain empty files for various
+ # reasons, Doxygen generates empty *.map files, and Python
+ # uses __init__.py to mark module directories.
+ unless ($item->name =~ m{^usr/share/doc/(?:[^/]+/)?examples/}
+ || $item->name
+ =~ m{^usr/share/doc/(?:.+/)?(?:doxygen|html)/.*[.]map$}s
+ || $item->name=~ m{^usr/share/doc/(?:.+/)?__init__[.]py$}s){
+
+ $self->pointed_hint('zero-byte-file-in-doc-directory',
+ $item->pointer);
+ }
+ }
+
+ if ( $item->name =~ / [.]gz $/msx
+ && $item->is_regular_file
+ && $item->size <= $MAXIMUM_EMPTY_GZIP_SIZE
+ && $item->file_type =~ / gzip \s compressed /msx) {
+
+ open(my $fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $f = <$fd>;
+ close($fd);
+
+ unless (defined $f and length $f) {
+ $self->pointed_hint('zero-byte-file-in-doc-directory',
+ $item->pointer);
+ }
+ }
+ }
+
+ # file directly in /usr/share/doc ?
+ $self->pointed_hint('file-directly-in-usr-share-doc', $item->pointer)
+ if $item->is_file
+ && $item->name =~ m{^ usr/share/doc/ [^/]+ $}x;
+
+ # contains an INSTALL file?
+ $self->pointed_hint('package-contains-upstream-installation-documentation',
+ $item->pointer)
+ if $item->name =~ m{^ usr/share/doc/ $ppkg / INSTALL (?: [.] .+ )* $}sx;
+
+ # contains a README for another distribution/platform?
+ $self->pointed_hint('package-contains-readme-for-other-platform-or-distro',
+ $item->pointer)
+ if $item->name =~ m{^usr/share/doc/$ppkg/readme[.]
+ (?:apple|aix|atari|be|beos|bsd|bsdi
+ |cygwin|darwin|irix|gentoo|freebsd|mac|macos
+ |macosx|netbsd|openbsd|osf|redhat|sco|sgi
+ |solaris|suse|sun|vms|win32|win9x|windows
+ )(?:[.]txt)?(?:[.]gz)?$}xi;
+
+ # contains a compressed version of objects.inv in
+ # sphinx-generated documentation?
+ $self->pointed_hint('compressed-documentation', $item->pointer)
+ if $item->name
+ =~ m{^ usr/share/doc/ $ppkg / (?: [^/]+ / )+ objects [.]inv [.]gz $}x
+ && $item->file_type =~ m{gzip compressed};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Documentation/Devhelp.pm b/lib/Lintian/Check/Documentation/Devhelp.pm
new file mode 100644
index 0000000..cd186a5
--- /dev/null
+++ b/lib/Lintian/Check/Documentation/Devhelp.pm
@@ -0,0 +1,87 @@
+# documentation/devhelp -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2022 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Documentation::Devhelp;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# *.devhelp and *.devhelp2 files must be accessible from a directory in
+# the devhelp search path: /usr/share/devhelp/books and
+# /usr/share/gtk-doc/html. We therefore look for any links in one of
+# those directories to another directory. The presence of such a link
+# blesses any file below that other directory.
+has reachable_folders => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @reachable_folders;
+
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ # in search path
+ next
+ unless $item->name
+ =~ m{^ usr/share/ (?: devhelp/books | gtk-doc/html ) / }x;
+
+ next
+ unless length $item->link;
+
+ my $followed = $item->link_normalized;
+
+ # drop broken links
+ push(@reachable_folders, $followed)
+ if length $followed;
+ }
+
+ return \@reachable_folders;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # locate Devhelp files not discoverable by Devhelp
+ $self->pointed_hint('stray-devhelp-documentation', $item->pointer)
+ if $item->name =~ m{ [.]devhelp2? (?: [.]gz )? $}x
+ && $item->name !~ m{^ usr/share/ (?: devhelp/books | gtk-doc/html ) / }x
+ && (none { $item->name =~ /^\Q$_\E/ } @{$self->reachable_folders});
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Documentation/Devhelp/Standard.pm b/lib/Lintian/Check/Documentation/Devhelp/Standard.pm
new file mode 100644
index 0000000..05d77db
--- /dev/null
+++ b/lib/Lintian/Check/Documentation/Devhelp/Standard.pm
@@ -0,0 +1,47 @@
+# documentation/devhelp/standard -- lintian check script -*- perl -*-
+
+# Copyright (C) 2022 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Documentation::Devhelp::Standard;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('old-devhelp-standard', $item->pointer)
+ if $item->name =~ m{ [.]devhelp (?: [.]gz )? $}x;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Documentation/Doxygen.pm b/lib/Lintian/Check/Documentation/Doxygen.pm
new file mode 100644
index 0000000..206a4b8
--- /dev/null
+++ b/lib/Lintian/Check/Documentation/Doxygen.pm
@@ -0,0 +1,75 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Documentation::Doxygen;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('source-contains-prebuilt-doxygen-documentation',
+ $item->parent_dir->pointer)
+ if $item->basename =~ m{^doxygen.(?:png|sty)$}
+ && $self->processable->source_name ne 'doxygen';
+
+ return
+ unless $item->basename =~ /\.(?:x?html?\d?|xht)$/i;
+
+ my $contents = $item->decoded_utf8;
+ return
+ unless length $contents;
+
+ my $lowercase = lc($contents);
+
+ # Identify and ignore documentation templates by looking
+ # for the use of various interpolated variables.
+ # <http://www.doxygen.nl/manual/config.html#cfg_html_header>
+ $self->pointed_hint('source-contains-prebuilt-doxygen-documentation',
+ $item->pointer)
+ if $lowercase =~ m{<meta \s+ name="generator" \s+ content="doxygen}smx
+ && $lowercase
+ !~ /\$(?:doxygenversion|projectname|projectnumber|projectlogo)\b/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Documentation/Examples.pm b/lib/Lintian/Check/Documentation/Examples.pm
new file mode 100644
index 0000000..4c1b84a
--- /dev/null
+++ b/lib/Lintian/Check/Documentation/Examples.pm
@@ -0,0 +1,48 @@
+# documentation/examples -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Documentation::Examples;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('nested-examples-directory', $item->pointer)
+ if $item->is_dir
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/examples/?$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Documentation/Manual.pm b/lib/Lintian/Check/Documentation/Manual.pm
new file mode 100644
index 0000000..4171ef6
--- /dev/null
+++ b/lib/Lintian/Check/Documentation/Manual.pm
@@ -0,0 +1,663 @@
+# documentation/manual -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Documentation::Manual;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd qw(getcwd);
+use File::Basename;
+use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
+use IPC::Run3;
+use List::Compare;
+use List::SomeUtils qw(any none);
+use Path::Tiny;
+use Text::Balanced qw(extract_delimited);
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Spelling qw(check_spelling);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $COLON => q{:};
+const my $COMMA => q{,};
+const my $DOT => q{.};
+const my $NEWLINE => qq{\n};
+
+const my $USER_COMMAND_SECTION => 1;
+const my $SYSTEM_COMMAND_SECTION => 8;
+
+const my $WAIT_STATUS_SHIFT => 8;
+const my $MINIMUM_SHARED_OBJECT_SIZE => 256;
+const my $WIDE_SCREEN => 120;
+
+has local_manpages => (is => 'rw', default => sub { {} });
+
+sub spelling_tag_emitter {
+ my ($self, $tag_name, $pointer, @orig_args) = @_;
+
+ return sub {
+ return $self->pointed_hint($tag_name, $pointer, @orig_args, @_);
+ };
+}
+
+my @user_locations= qw(bin/ usr/bin/ usr/bin/X11/ usr/bin/mh/ usr/games/);
+my @admin_locations= qw(sbin/ usr/sbin/ usr/libexec/);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # no man pages in udebs
+ return
+ if $self->processable->type eq 'udeb';
+
+ if ($item->name =~ m{^usr/share/man/\S+}) {
+
+ $self->pointed_hint('manual-page-in-udeb', $item->pointer)
+ if $self->processable->type eq 'udeb';
+
+ if ($item->is_dir) {
+ $self->pointed_hint('stray-folder-in-manual', $item->pointer)
+ unless $item->name
+ =~ m{^usr/(?:X11R6|share)/man/(?:[^/]+/)?(?:man\d/)?$};
+
+ } elsif ($item->is_file && $item->is_executable) {
+ $self->pointed_hint('executable-manual-page', $item->pointer);
+ }
+ }
+
+ return
+ unless $item->is_file || $item->is_symlink;
+
+ my ($manpage, $page_path, undef) = fileparse($item);
+
+ if ($page_path eq 'usr/share/man/' && $manpage ne $EMPTY) {
+ $self->pointed_hint('odd-place-for-manual-page', $item->pointer);
+ return;
+ }
+
+ # manual page?
+ my ($subdir) = ($page_path =~ m{^usr/share/man(/\S+)});
+ return
+ unless defined $subdir;
+
+ $self->pointed_hint('build-path-in-manual', $item->pointer)
+ if $item =~ m{/_build_} || $item =~ m{_tmp_buildd};
+
+ $self->pointed_hint('manual-page-with-generic-name', $item->pointer)
+ if $item =~ m{/README\.};
+
+ my ($section) = ($subdir =~ m{^.*man(\d)/$});
+ unless (defined $section) {
+ $self->pointed_hint('odd-place-for-manual-page', $item->pointer);
+ return;
+ }
+
+ my ($language) = ($subdir =~ m{^/([^/]+)/man\d/$});
+ $language //= $EMPTY;
+
+ # The country should not be part of the man page locale
+ # directory unless it's one of the known cases where the
+ # language is significantly different between countries.
+ $self->pointed_hint('country-in-manual', $item->pointer)
+ if $language =~ /_/ && $language !~ /^(?:pt_BR|zh_[A-Z][A-Z])$/;
+
+ my @pieces = split(/\./, $manpage);
+ my $ext = pop @pieces;
+
+ if ($ext ne 'gz') {
+
+ push @pieces, $ext;
+ $self->pointed_hint('uncompressed-manual-page', $item->pointer);
+
+ } elsif ($item->is_file) { # so it's .gz... files first; links later
+
+ if ($item->file_type !~ m/gzip compressed data/) {
+ $self->pointed_hint('wrong-compression-in-manual-page',
+ $item->pointer);
+
+ } elsif ($item->file_type !~ m/max compression/) {
+ $self->pointed_hint('poor-compression-in-manual-page',
+ $item->pointer);
+ }
+ }
+
+ my $fn_section = pop @pieces;
+ my $section_num = $fn_section;
+
+ if (scalar @pieces && $section_num =~ s/^(\d).*$/$1/) {
+
+ my $bin = join($DOT, @pieces);
+ $self->local_manpages->{$bin} = []
+ unless $self->local_manpages->{$bin};
+
+ push @{$self->local_manpages->{$bin}},
+ { file => $item, language => $language, section => $section };
+
+ # number of directory and manpage extension equal?
+ if ($section_num != $section) {
+ $self->pointed_hint('odd-place-for-manual-page', $item->pointer);
+ }
+
+ } else {
+ $self->pointed_hint('wrong-name-for-manual-page', $item->pointer);
+ }
+
+ # check symbolic links to other manual pages
+ if ($item->is_symlink) {
+ if ($item->link =~ m{(^|/)undocumented}) {
+ # undocumented link in /usr/share/man -- possibilities
+ # undocumented... (if in the appropriate section)
+ # ../man?/undocumented...
+ # ../../man/man?/undocumented...
+ # ../../../share/man/man?/undocumented...
+ # ../../../../usr/share/man/man?/undocumented...
+ if (
+ (
+ $item->link =~ m{^undocumented\.([237])\.gz}
+ && $page_path =~ m{^usr/share/man/man$1}
+ )
+ || $item->link =~ m{^\.\./man[237]/undocumented\.[237]\.gz$}
+ || $item->link
+ =~ m{^\.\./\.\./man/man[237]/undocumented\.[237]\.gz$}
+ || $item->link
+ =~ m{^\.\./\.\./\.\./share/man/man[237]/undocumented\.[237]\.gz$}
+ || $item->link
+ =~ m{^\.\./\.\./\.\./\.\./usr/share/man/man[237]/undocumented\.[237]\.gz$}
+ ) {
+ $self->pointed_hint('undocumented-manual-page',$item->pointer);
+ } else {
+ $self->pointed_hint('broken-link-to-undocumented',
+ $item->pointer);
+ }
+ }
+ } else { # not a symlink
+
+ my $fd;
+ if ($item->file_type =~ m/gzip compressed/) {
+
+ open($fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ } else {
+
+ open($fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+ }
+
+ my @manfile = <$fd>;
+ close $fd;
+
+ # Is it a .so link?
+ if ($item->size < $MINIMUM_SHARED_OBJECT_SIZE) {
+
+ my ($i, $first) = (0, $EMPTY);
+ do {
+ $first = $manfile[$i++] || $EMPTY;
+ } while ($first =~ /^\.\\"/ && $manfile[$i]); #");
+
+ unless ($first) {
+ $self->pointed_hint('empty-manual-page', $item->pointer);
+ return;
+
+ } elsif ($first =~ /^\.so\s+(.+)?$/) {
+ my $dest = $1;
+ if ($dest =~ m{^([^/]+)/(.+)$}) {
+
+ my ($manxorlang, $remainder) = ($1, $2);
+
+ if ($manxorlang !~ /^man\d+$/) {
+ # then it's likely a language subdir, so let's run
+ # the other component through the same check
+ if ($remainder =~ m{^([^/]+)/(.+)$}) {
+
+ my $rest = $2;
+ $self->pointed_hint(
+ 'bad-so-link-within-manual-page',
+ $item->pointer)
+ unless $rest =~ m{^[^/]+\.\d(?:\S+)?(?:\.gz)?$};
+
+ } else {
+ $self->pointed_hint(
+ 'bad-so-link-within-manual-page',
+ $item->pointer);
+ }
+ }
+
+ } else {
+ $self->pointed_hint('bad-so-link-within-manual-page',
+ $item->pointer);
+ }
+ return;
+ }
+ }
+
+ # If it's not a .so link, use lexgrog to find out if the
+ # man page parses correctly and make sure the short
+ # description is reasonable.
+ #
+ # This check is currently not applied to pages in
+ # language-specific hierarchies, because those pages are
+ # not currently scanned by mandb (bug #29448), and because
+ # lexgrog can't handle pages in all languages at the
+ # moment, leading to huge numbers of false negatives. When
+ # man-db is fixed, this limitation should be removed.
+ if ($page_path =~ m{/man/man\d/}) {
+
+ delete local $ENV{$_}
+ for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV;
+ local $ENV{LC_ALL} = 'C.UTF-8';
+
+ my @command = ('lexgrog', $item->unpacked_path);
+
+ my $stdout;
+ my $stderr;
+
+ run3(\@command, \undef, \$stdout, \$stderr);
+
+ my $exitcode = $?;
+ my $status = ($exitcode >> $WAIT_STATUS_SHIFT);
+
+ $self->pointed_hint('bad-whatis-entry', $item->pointer)
+ if $status == 2;
+
+ if ($status != 0 && $status != 2) {
+ my $message = "Non-zero status $status from @command";
+ $message .= $COLON . $NEWLINE . $stderr
+ if length $stderr;
+
+ warn encode_utf8($message);
+
+ } else {
+ my $desc = $stdout;
+ $desc =~ s/^[^:]+: \"(.*)\"$/$1/;
+
+ if ($desc =~ /(\S+)\s+-\s+manual page for \1/i) {
+ $self->pointed_hint('useless-whatis-entry',$item->pointer);
+
+ } elsif ($desc =~ /\S+\s+-\s+programs? to do something/i) {
+ $self->pointed_hint('manual-page-from-template',
+ $item->pointer);
+ }
+ }
+ }
+
+ # If it's not a .so link, run it through 'man' to check for errors.
+ # If it is in a directory with the standard man layout, cd to the
+ # parent directory before running man so that .so directives are
+ # processed properly. (Yes, there are man pages that include other
+ # pages with .so but aren't simple links; rbash, for instance.)
+ {
+ delete local $ENV{$_}
+ for grep { $_ ne 'PATH' && $_ ne 'TMPDIR' } keys %ENV;
+ local $ENV{LC_ALL} = 'C.UTF-8';
+
+ local $ENV{MANROFFSEQ} = $EMPTY;
+
+ # set back to 80 when Bug#892423 is fixed in groff
+ local $ENV{MANWIDTH} = $WIDE_SCREEN;
+
+ my $stdout;
+ my $stderr;
+
+ my @command = qw(man --warnings -E UTF-8 -l -Tutf8 -Z);
+ push(@command, $item->unpacked_path);
+
+ my $localdir = path($item->unpacked_path)->parent->stringify;
+ $localdir =~ s{^(.*)/man\d\b}{$1}s;
+
+ my $savedir = getcwd;
+ chdir($localdir)
+ or die encode_utf8('Cannot change directory ' . $localdir);
+
+ run3(\@command, \undef, \$stdout, \$stderr);
+
+ my $exitcode = $?;
+ my $status = ($exitcode >> $WAIT_STATUS_SHIFT);
+
+ my @lines = split(/\n/, $stderr);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ chomp $line;
+
+ # Devel::Cover causes some annoying deep recursion
+ # warnings and sometimes in our child process.
+ # Filter them out, but only during coverage.
+ next
+ if $ENV{LINTIAN_COVERAGE}
+ && $line =~ m{
+ \A Deep [ ] recursion [ ] on [ ] subroutine [ ]
+ "[^"]+" [ ] at [ ] .*B/Deparse.pm [ ] line [ ]
+ \d+}xsm;
+
+ # ignore progress information from man
+ next
+ if $line =~ /^Reformatting/;
+
+ next
+ if $line =~ /^\s*$/;
+
+ # ignore errors from gzip; dealt with elsewhere
+ next
+ if $line =~ /^\bgzip\b/;
+
+ # ignore wrapping failures for Asian man pages (groff problem)
+ if ($language =~ /^(?:ja|ko|zh)/) {
+ next
+ if $line =~ /warning \[.*\]: cannot adjust line/;
+ next
+ if $line =~ /warning \[.*\]: can\'t break line/;
+ }
+
+ # ignore wrapping failures if they contain URLs (.UE is an
+ # extension for marking the end of a URL).
+ next
+ if $line
+ =~ /:(\d+): warning \[.*\]: (?:can\'t break|cannot adjust) line/
+ && ( $manfile[$1 - 1] =~ m{(?:https?|ftp|file)://.+}i
+ || $manfile[$1 - 1] =~ m{^\s*\.\s*UE\b});
+
+ # ignore common undefined macros from pod2man << Perl 5.10
+ next
+ if $line =~ /warning: (?:macro )?\'(?:Tr|IX)\' not defined/;
+
+ $line =~ s/^[^:]+: //;
+ $line =~ s/^<standard input>://;
+
+ $self->pointed_hint('groff-message',
+ $item->pointer($position), $line);
+ } continue {
+ ++$position;
+ }
+
+ chdir($savedir)
+ or die encode_utf8('Cannot change directory ' . $savedir);
+
+ }
+
+ # Now we search through the whole man page for some common errors
+ my $position = 1;
+ my $seen_python_traceback;
+ for my $line (@manfile) {
+
+ chomp $line;
+
+ next
+ if $line =~ /^\.\\\"/; # comments .\"
+
+ if ($line =~ /^\.TH\s/) {
+
+ # title header
+ my $consumed = $line;
+ $consumed =~ s/ [.]TH \s+ //msx;
+
+ my ($delimited, $after_names) = extract_delimited($consumed);
+ unless (length $delimited) {
+ $consumed =~ s/ ^ \s* \S+ , //gmsx;
+ $consumed =~ s/ ^ \s* \S+ //msx;
+ $after_names = $consumed;
+ }
+
+ my ($th_section) = extract_delimited($after_names);
+ if (length $th_section) {
+
+ # drop initial delimiter
+ $th_section =~ s/ ^. //msx;
+
+ # drop final delimiter
+ $th_section =~ s/ .$ //msx;
+
+ # unescape
+ $th_section =~ s/ [\\](.) /$1/gmsx;
+
+ } elsif (length $after_names
+ && $after_names =~ / ^ \s* (\S+) /msx) {
+ $th_section = $1;
+ }
+
+ $self->pointed_hint(
+ 'wrong-manual-section',
+ $item->pointer($position),
+ "$fn_section != $th_section"
+ )if length $th_section && fc($th_section) ne fc($fn_section);
+ }
+
+ if ( ($line =~ m{(/usr/(dict|doc|etc|info|man|adm|preserve)/)})
+ || ($line =~ m{(/var/(adm|catman|named|nis|preserve)/)})){
+ # FSSTND dirs in man pages
+ # regexes taken from checks/files
+ $self->pointed_hint('FSSTND-dir-in-manual-page',
+ $item->pointer($position), $1);
+ }
+
+ if ($line eq '.SH "POD ERRORS"') {
+ $self->pointed_hint('pod-conversion-message',
+ $item->pointer($position));
+ }
+
+ if ($line =~ /Traceback \(most recent call last\):/) {
+ $self->pointed_hint('python-traceback-in-manpage',
+ $item->pointer)
+ unless $seen_python_traceback;
+ $seen_python_traceback = 1;
+ }
+
+ # Check for spelling errors if the manpage is English
+ my $stag_emitter
+ = $self->spelling_tag_emitter('typo-in-manual-page',
+ $item->pointer($position));
+ check_spelling($self->data, $line,
+ $self->group->spelling_exceptions,
+ $stag_emitter, 0)
+ if $page_path =~ m{/man/man\d/};
+
+ } continue {
+ ++$position;
+ }
+ }
+
+ # most man pages are zipped
+ my $bytes;
+ if ($item->file_type =~ /gzip compressed/) {
+
+ my $path = $item->unpacked_path;
+ gunzip($path => \$bytes)
+ or die encode_utf8("gunzip $path failed: $GunzipError");
+
+ } elsif ($item->file_type =~ /^troff/ || $item->file_type =~ /text$/) {
+ $bytes = $item->bytes;
+ }
+
+ return
+ unless length $bytes;
+
+ # another check complains about invalid encoding
+ return
+ unless valid_utf8($bytes);
+
+ my $contents = decode_utf8($bytes);
+ my @lines = split(/\n/, $contents);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ # see Bug#554897 and Bug#507673; exclude string variables
+ $self->pointed_hint('acute-accent-in-manual-page',
+ $item->pointer($position))
+ if $line =~ /\\'/ && $line !~ /^\.\s*ds\s/;
+
+ } continue {
+ $position++;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ # no man pages in udebs
+ return
+ if $self->processable->type eq 'udeb';
+
+ my %local_user_executables;
+ my %local_admin_executables;
+
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ next
+ unless $item->is_symlink || $item->is_file;
+
+ my ($name, $path, undef) = fileparse($item->name);
+
+ $local_user_executables{$name} = $item
+ if any { $path eq $_ } @user_locations;
+
+ $local_admin_executables{$name} = $item
+ if any { $path eq $_ } @admin_locations;
+ }
+
+ my %local_executables= (%local_user_executables, %local_admin_executables);
+ my @local_commands = keys %local_executables;
+
+ my @direct_reliants
+ =@{$self->group->direct_reliants($self->processable) // []};
+ my @reliant_files = map { @{$_->installed->sorted_list} } @direct_reliants;
+
+ # for executables, look at packages relying on the current processable
+ my %distant_executables;
+ for my $item (@reliant_files) {
+
+ next
+ unless $item->is_file || $item->is_symlink;
+
+ my ($name, $path, undef) = fileparse($item, qr{\..+$});
+
+ $distant_executables{$name} = $item
+ if any { $path eq $_ } (@user_locations, @admin_locations);
+ }
+
+ my @distant_commands = keys %distant_executables;
+ my @related_commands = (@local_commands, @distant_commands);
+
+ my @direct_prerequisites
+ =@{$self->group->direct_dependencies($self->processable) // []};
+ my@prerequisite_files
+ = map { @{$_->installed->sorted_list} } @direct_prerequisites;
+
+ # for manpages, look at packages the current processable relies upon
+ my %distant_manpages;
+ for my $item (@prerequisite_files) {
+
+ next
+ unless $item->is_file || $item->is_symlink;
+
+ my ($name, $path, undef) = fileparse($item, qr{\..+$});
+
+ next
+ unless $path =~ m{^usr/share/man/\S+};
+
+ next
+ unless $path =~ m{man\d/$};
+
+ my ($language) = ($path =~ m{/([^/]+)/man\d/$});
+ $language //= $EMPTY;
+ $language = $EMPTY if $language eq 'man';
+
+ $distant_manpages{$name} //= [];
+
+ push @{$distant_manpages{$name}},
+ {file => $item, language => $language};
+ }
+
+ my %local_manpages = %{$self->local_manpages};
+ my %related_manpages = (%local_manpages, %distant_manpages);
+
+ # provides sorted output
+ my $related
+ = List::Compare->new(\@local_commands, [keys %related_manpages]);
+ my @documented = $related->get_intersection;
+ my @manpage_missing = $related->get_Lonly;
+
+ my @english_missing = grep {
+ none {$_->{language} eq $EMPTY}
+ @{$related_manpages{$_} // []}
+ } @documented;
+
+ for my $command (keys %local_admin_executables) {
+
+ my $item = $local_admin_executables{$command};
+ my @manpages = @{$related_manpages{$command} // []};
+
+ my @sections = grep { defined } map { $_->{section} } @manpages;
+ $self->pointed_hint('manual-page-for-system-command', $item->pointer)
+ if $item->is_regular_file
+ && any { $_ == $USER_COMMAND_SECTION } @sections;
+ }
+
+ for (map {$local_executables{$_}} @english_missing) {
+ $self->pointed_hint('no-english-manual-page', $_->pointer)
+ unless $_->name =~ m{/libexec/};
+ }
+
+ for (map {$local_executables{$_}} @manpage_missing) {
+ $self->pointed_hint('no-manual-page', $_->pointer)
+ unless $_->name =~ m{/libexec/};
+ }
+
+ # surplus manpages only for this package; provides sorted output
+ my $local = List::Compare->new(\@related_commands, [keys %local_manpages]);
+ my @surplus_manpages = $local->get_Ronly;
+
+ # filter out sub commands, underscore for libreswan; see Bug#947258
+ for my $command (@related_commands) {
+ @surplus_manpages = grep { !/^$command(?:\b|_)/ } @surplus_manpages;
+ }
+
+ for my $manpage (map { @{$local_manpages{$_} // []} } @surplus_manpages) {
+
+ my $item = $manpage->{file};
+ my $section = $manpage->{section};
+
+ $self->pointed_hint('spare-manual-page', $item->pointer)
+ if $section == $USER_COMMAND_SECTION
+ || $section == $SYSTEM_COMMAND_SECTION;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Documentation/Texinfo.pm b/lib/Lintian/Check/Documentation/Texinfo.pm
new file mode 100644
index 0000000..cc4be39
--- /dev/null
+++ b/lib/Lintian/Check/Documentation/Texinfo.pm
@@ -0,0 +1,195 @@
+# documentation/texinfo -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2001 Josip Rodin
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Documentation::Texinfo;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+use List::SomeUtils qw(uniq);
+
+use Lintian::Util qw(normalize_link_target);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub binary {
+ my ($self) = @_;
+
+ my $info_dir
+ = $self->processable->installed->resolve_path('usr/share/info/');
+ return
+ unless $info_dir;
+
+ # Read package contents...
+ for my $item ($info_dir->descendants) {
+
+ next
+ unless $item->is_symlink
+ || $item->is_file;
+
+ # Ignore dir files. That's a different error which we already catch in
+ # the files check.
+ next
+ if $item->basename =~ /^dir(?:\.old)?(?:\.gz)?/;
+
+ # Analyze the file names making sure the documents are named
+ # properly. Note that Emacs 22 added support for images in
+ # info files, so we have to accept those and ignore them.
+ # Just ignore .png files for now.
+ my @fname_pieces = split(m{ [.] }x, $item->basename);
+ my $extension = pop @fname_pieces;
+
+ if ($extension eq 'gz') { # ok!
+ if ($item->is_file) {
+
+ # compressed with maximum compression rate?
+ if ($item->file_type !~ m/gzip compressed data/) {
+ $self->pointed_hint(
+ 'info-document-not-compressed-with-gzip',
+ $item->pointer);
+
+ } else {
+ if ($item->file_type !~ m/max compression/) {
+ $self->pointed_hint(
+'info-document-not-compressed-with-max-compression',
+ $item->pointer
+ );
+ }
+ }
+ }
+
+ } elsif ($extension =~ m/^(?:png|jpe?g)$/) {
+ next;
+
+ } else {
+ push(@fname_pieces, $extension);
+ $self->pointed_hint('info-document-not-compressed',$item->pointer);
+ }
+
+ my $infoext = pop @fname_pieces;
+ unless ($infoext && $infoext =~ /^info(-\d+)?$/) { # it's not foo.info
+
+ # it's not foo{,-{1,2,3,...}}
+ $self->pointed_hint('info-document-has-wrong-extension',
+ $item->pointer)
+ if @fname_pieces;
+ }
+
+ # If this is the main info file (no numeric extension). make
+ # sure it has appropriate dir entry information.
+ if ( $item->basename !~ /-\d+\.gz/
+ && $item->file_type =~ /gzip compressed data/) {
+
+ # unsafe symlink, skip. Actually, this should never
+ # be true as "$file_type" for symlinks will not be
+ # "gzip compressed data". But for good measure.
+ next
+ unless $item->is_open_ok;
+
+ open(my $fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my ($section, $start, $end);
+ while (my $line = <$fd>) {
+
+ $section = 1
+ if $line =~ /^INFO-DIR-SECTION\s+\S/;
+
+ $start = 1
+ if $line =~ /^START-INFO-DIR-ENTRY\b/;
+
+ $end = 1
+ if $line =~ /^END-INFO-DIR-ENTRY\b/;
+ }
+
+ close $fd;
+
+ $self->pointed_hint('info-document-missing-dir-section',
+ $item->pointer)
+ unless $section;
+
+ $self->pointed_hint('info-document-missing-dir-entry',
+ $item->pointer)
+ unless $start && $end;
+ }
+
+ # Check each [image src=""] form in the info files. The src
+ # filename should be in the package. As of Texinfo 5 it will
+ # be something.png or something.jpg, but that's not enforced.
+ #
+ # See Texinfo manual (info "(texinfo)Info Format Image") for
+ # details of the [image] form. Bytes \x00,\x08 introduce it
+ # (and distinguishes it from [image] appearing as plain text).
+ #
+ # String src="..." part has \" for literal " and \\ for
+ # literal \, though that would be unlikely in filenames. For
+ # the tag() message show $src unbackslashed since that's the
+ # filename sought.
+ #
+ if ($item->is_file && $item->basename =~ /\.info(?:-\d+)?\.gz$/) {
+
+ open(my $fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my @missing;
+ while ($line =~ /[\0][\b]\[image src="((?:\\.|[^\"])+)"/smg) {
+
+ my $src = $1;
+ $src =~ s/\\(.)/$1/g; # unbackslash
+
+ push(@missing, $src)
+ unless $self->processable->installed->lookup(
+ normalize_link_target('usr/share/info', $src));
+ }
+
+ $self->pointed_hint('info-document-missing-image-file',
+ $item->pointer($position), $_)
+ for uniq @missing;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Emacs.pm b/lib/Lintian/Check/Emacs.pm
new file mode 100644
index 0000000..6c6f94e
--- /dev/null
+++ b/lib/Lintian/Check/Emacs.pm
@@ -0,0 +1,58 @@
+# emacs -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Emacs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $WIDELY_READABLE => oct(644);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # /etc/emacs.*
+ if ( $item->is_file
+ && $item->name =~ m{^etc/emacs.*/\S}
+ && $item->operm != $WIDELY_READABLE) {
+
+ $self->pointed_hint('bad-permissions-for-etc-emacs-script',
+ $item->pointer,
+ sprintf('%04o != %04o', $item->operm, $WIDELY_READABLE));
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Emacs/Elpa.pm b/lib/Lintian/Check/Emacs/Elpa.pm
new file mode 100644
index 0000000..9b3528a
--- /dev/null
+++ b/lib/Lintian/Check/Emacs/Elpa.pm
@@ -0,0 +1,51 @@
+# emacs/elpa -- lintian check script -*- perl -*-
+
+# Copyright (C) 2017 Sean Whitton
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Emacs::Elpa;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint('emacsen-common-without-dh-elpa')
+ if defined $self->processable->installed->lookup(
+ 'usr/lib/emacsen-common/packages/install/')
+ && !
+ defined $self->processable->installed->lookup(
+ 'usr/share/emacs/site-lisp/elpa-src/');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Examples.pm b/lib/Lintian/Check/Examples.pm
new file mode 100644
index 0000000..ef9a452
--- /dev/null
+++ b/lib/Lintian/Check/Examples.pm
@@ -0,0 +1,82 @@
+# Check::Examples -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Examples;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has group_ships_examples => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @processables = $self->group->get_installables;
+
+ # assume shipped examples if there is a package so named
+ return 1
+ if any { $_->name =~ m{-examples$} } @processables;
+
+ my @shipped = map { @{$_->installed->sorted_list} } @processables;
+
+ # Check each package for a directory (or symlink) called "examples".
+ return 1
+ if any { m{^usr/share/doc/(.+/)?examples/?$} } @shipped;
+
+ return 0;
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ # some installation files must be present; see Bug#972614
+ $self->pointed_hint('package-does-not-install-examples', $item->pointer)
+ if $item->basename eq 'examples'
+ && $item->dirname !~ m{(?:^|/)(?:vendor|third_party)/}
+ && $self->group->get_installables
+ && !$self->group_ships_examples;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Executable.pm b/lib/Lintian/Check/Executable.pm
new file mode 100644
index 0000000..37fcb67
--- /dev/null
+++ b/lib/Lintian/Check/Executable.pm
@@ -0,0 +1,59 @@
+# executable -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Executable;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('executable-not-elf-or-script', $item->pointer)
+ if $item->is_executable
+ && $item->file_type !~ / ^ [^,]* \b ELF \b /msx
+ && !$item->is_script
+ && !$item->is_hardlink
+ && $item->name !~ m{^ usr(?:/X11R6)?/man/ }x
+ && $item->name !~ m/ [.]exe $/x # mono convention
+ && $item->name !~ m/ [.]jar $/x; # Debian Java policy 2.2
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Architecture.pm b/lib/Lintian/Check/Fields/Architecture.pm
new file mode 100644
index 0000000..caa5814
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Architecture.pm
@@ -0,0 +1,132 @@
+# fields/architecture -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Architecture;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+has installable_architecture => (is => 'rw', default => $EMPTY);
+
+sub installable {
+ my ($self) = @_;
+
+ my @installable_architectures
+ = $self->processable->fields->trimmed_list('Architecture');
+ return
+ unless @installable_architectures;
+
+ for my $installable_architecture (@installable_architectures) {
+ $self->hint('arch-wildcard-in-binary-package',
+ $installable_architecture)
+ if $self->data->architectures->is_wildcard(
+ $installable_architecture);
+ }
+
+ $self->hint('too-many-architectures', (sort @installable_architectures))
+ if @installable_architectures > 1;
+
+ my $installable_architecture = $installable_architectures[0];
+
+ $self->hint('aspell-package-not-arch-all')
+ if $self->processable->name =~ /^aspell-[a-z]{2}(?:-.*)?$/
+ && $installable_architecture ne 'all';
+
+ $self->hint('documentation-package-not-architecture-independent')
+ if $self->processable->name =~ /-docs?$/
+ && $installable_architecture ne 'all';
+
+ return;
+}
+
+sub always {
+ my ($self) = @_;
+
+ my @installable_architectures
+ = $self->processable->fields->trimmed_list('Architecture');
+ for my $installable_architecture (@installable_architectures) {
+
+ $self->hint('unknown-architecture', $installable_architecture)
+ unless $self->data->architectures->is_release_architecture(
+ $installable_architecture)
+ || $self->data->architectures->is_wildcard($installable_architecture)
+ || $installable_architecture eq 'all'
+ || (
+ $installable_architecture eq 'source'
+ && ( $self->processable->type eq 'changes'
+ || $self->processable->type eq 'buildinfo')
+ );
+ }
+
+ # check for magic installable architecture combinations
+ if (@installable_architectures > 1) {
+
+ my $magic_error = 0;
+
+ if (any { $_ eq 'all' } @installable_architectures) {
+ $magic_error++
+ unless any { $self->processable->type eq $_ }
+ qw(source changes buildinfo);
+ }
+
+ my $anylc = List::Compare->new(\@installable_architectures, ['any']);
+ if ($anylc->get_intersection) {
+
+ my @errorset = $anylc->get_Lonly;
+
+ # Allow 'all' to be present in source packages as well
+ # (#626775)
+ @errorset = grep { $_ ne 'all' } @errorset
+ if any { $self->processable->type eq $_ }
+ qw(source changes buildinfo);
+
+ $magic_error++
+ if @errorset;
+ }
+
+ $self->hint('magic-arch-in-arch-list') if $magic_error;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Bugs.pm b/lib/Lintian/Check/Fields/Bugs.pm
new file mode 100644
index 0000000..6485650
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Bugs.pm
@@ -0,0 +1,62 @@
+# fields/bugs -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Bugs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Bugs');
+
+ my $bugs = $fields->unfolded_value('Bugs');
+
+ $self->hint('redundant-bugs-field')
+ if $bugs =~ m{^debbugs://bugs.debian.org/?$}i;
+
+ $self->hint('bugs-field-does-not-refer-to-debian-infrastructure', $bugs)
+ unless $bugs =~ m{\.debian\.org}
+ || $self->processable->name =~ /[-]dbgsym$/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/BuiltUsing.pm b/lib/Lintian/Check/Fields/BuiltUsing.pm
new file mode 100644
index 0000000..5da9475
--- /dev/null
+++ b/lib/Lintian/Check/Fields/BuiltUsing.pm
@@ -0,0 +1,72 @@
+# fields/built-using -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::BuiltUsing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+use Lintian::Util qw($PKGNAME_REGEX $PKGVERSION_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ return
+ unless $processable->fields->declares('Built-Using');
+
+ my $built_using = $processable->fields->value('Built-Using');
+
+ my $built_using_rel = Lintian::Relation->new->load($built_using);
+ $built_using_rel->visit(
+ sub {
+ my ($package) = @_;
+ if ($package !~ /^$PKGNAME_REGEX \(= $PKGVERSION_REGEX\)$/) {
+ $self->hint('invalid-value-in-built-using-field', $package);
+ return 1;
+ }
+ return 0;
+ },
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL
+ | Lintian::Relation::VISIT_STOP_FIRST_MATCH
+ );
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/ChangedBy.pm b/lib/Lintian/Check/Fields/ChangedBy.pm
new file mode 100644
index 0000000..4f58b1b
--- /dev/null
+++ b/lib/Lintian/Check/Fields/ChangedBy.pm
@@ -0,0 +1,66 @@
+# changed-by -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software. It is distributed under the terms of
+# the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any
+# later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::ChangedBy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub changes {
+ my ($self) = @_;
+
+ # Changed-By is optional in Policy, but if set, must be
+ # syntactically correct. It's also used by dak.
+ return
+ unless $self->processable->fields->declares('Changed-By');
+
+ my $changed_by = $self->processable->fields->value('Changed-By');
+
+ my $DERIVATIVE_CHANGED_BY
+ = $self->data->load('common/derivative-changed-by',qr/\s*~~\s*/);
+
+ for my $regex ($DERIVATIVE_CHANGED_BY->all) {
+
+ next
+ if $changed_by =~ /$regex/;
+
+ my $explanation = $DERIVATIVE_CHANGED_BY->value($regex);
+ $self->hint('changed-by-invalid-for-derivative',
+ $changed_by, "($explanation)");
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Checksums.pm b/lib/Lintian/Check/Fields/Checksums.pm
new file mode 100644
index 0000000..2ea745e
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Checksums.pm
@@ -0,0 +1,53 @@
+# fields/checksums -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Checksums;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ $self->hint('no-strong-digests-in-dsc')
+ unless $processable->fields->declares('Checksums-Sha256');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Deb822.pm b/lib/Lintian/Check/Fields/Deb822.pm
new file mode 100644
index 0000000..d68fa6c
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Deb822.pm
@@ -0,0 +1,89 @@
+# fields/deb822 -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Deb822;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Syntax::Keyword::Try;
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SECTION => qq{\N{SECTION SIGN}};
+
+my @SOURCE_DEB822 = qw(debian/control);
+
+sub source {
+ my ($self) = @_;
+
+ for my $location (@SOURCE_DEB822) {
+
+ my $item = $self->processable->patched->resolve_path($location);
+ return
+ unless defined $item;
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->read_file($item->unpacked_path)
+
+ } catch {
+ next;
+ }
+
+ my $count = 1;
+ for my $section (@sections) {
+
+ for my $field_name ($section->names) {
+
+ my $field_value = $section->value($field_name);
+
+ my $position = $section->position($field_name);
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('trimmed-deb822-field', $pointer,
+ $SECTION . $count,
+ $field_name, $field_value);
+ }
+
+ } continue {
+ $count++;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Derivatives.pm b/lib/Lintian/Check/Fields/Derivatives.pm
new file mode 100644
index 0000000..4f42765
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Derivatives.pm
@@ -0,0 +1,88 @@
+# fields/derivatives -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Derivatives;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $HYPHEN => q{-};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has DERIVATIVE_FIELDS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %fields;
+
+ my $data= $self->data->load('fields/derivative-fields',qr/\s*\~\~\s*/);
+
+ for my $key ($data->all) {
+
+ my $value = $data->value($key);
+ my ($regexp, $explanation) = split(/\s*\~\~\s*/, $value, 2);
+ $fields{$key} = {
+ 'regexp' => qr/$regexp/,
+ 'explanation' => $explanation,
+ };
+ }
+
+ return \%fields;
+ }
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ for my $field (keys %{$self->DERIVATIVE_FIELDS}) {
+
+ my $val = $processable->fields->value($field) || $HYPHEN;
+ my $data = $self->DERIVATIVE_FIELDS->{$field};
+
+ $self->hint('invalid-field-for-derivative',
+ "$field: $val ($data->{'explanation'})")
+ if $val !~ m/$data->{'regexp'}/;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Description.pm b/lib/Lintian/Check/Fields/Description.pm
new file mode 100644
index 0000000..9bfd5bc
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Description.pm
@@ -0,0 +1,323 @@
+# fields/description -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Description;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Spelling qw(check_spelling check_spelling_picky);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Compared to a lower-case string, so it must be all lower-case
+const my $DH_MAKE_PERL_TEMPLATE =>
+'this description was automagically extracted from the module by dh-make-perl';
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+const my $DOUBLE_COLON => q{::};
+
+const my $MAXIMUM_WIDTH => 80;
+
+sub spelling_tag_emitter {
+ my ($self, @orig_args) = @_;
+ return sub {
+ return $self->hint(@orig_args, @_);
+ };
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $type = $self->processable->type;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my $tabs = 0;
+ my $template = 0;
+ my $unindented_list = 0;
+
+ return
+ unless $processable->fields->declares('Description');
+
+ my $full_description= $processable->fields->untrimmed_value('Description');
+
+ $full_description =~ m/^([^\n]*)\n(.*)$/s;
+ my ($synopsis, $extended) = ($1, $2);
+ unless (defined $synopsis) {
+ # The first line will always be completely stripped but
+ # continuations may have leading whitespace. Therefore we
+ # have to strip $full_description to restore this property,
+ # when we use it as a fall-back value of the synopsis.
+ $synopsis = $full_description;
+
+ # trim both ends
+ $synopsis =~ s/^\s+|\s+$//g;
+
+ $extended = $EMPTY;
+ }
+
+ $extended //= $EMPTY;
+
+ if ($synopsis =~ m/^\s*$/) {
+ $self->hint('description-synopsis-is-empty');
+ } else {
+ if ($synopsis =~ m/^\Q$pkg\E\b/i) {
+ $self->hint('description-starts-with-package-name');
+ }
+ if ($synopsis =~ m/^(an?|the)\s/i) {
+ $self->hint('description-synopsis-starts-with-article');
+ }
+ if ($synopsis =~ m/(.*\.)(?:\s*$|\s+\S+)/i) {
+ $self->hint('synopsis-is-a-sentence',"\"$synopsis\"")
+ unless $1 =~ m/\s+etc\.$/
+ or $1 =~ m/\s+e\.?g\.$/
+ or $1 =~ m/(?<!\.)\.\.\.$/;
+ }
+ if ($synopsis =~ m/\t/) {
+ $self->hint('description-contains-tabs') unless $tabs++;
+ }
+
+ $self->hint('odd-mark-in-description',
+ 'comma not followed by whitespace (synopsis)')
+ if $synopsis =~ /,[^\s\d]/;
+
+ if ($synopsis =~ m/^missing\s*$/i) {
+ $self->hint('description-is-debmake-template') unless $template++;
+ } elsif ($synopsis =~ m/<insert up to 60 chars description>/) {
+ $self->hint('description-is-dh_make-template') unless $template++;
+ }
+ if ($synopsis !~ m/\s/) {
+ $self->hint('description-too-short', $synopsis);
+ }
+ my $pkg_fmt = lc $pkg;
+ my $synopsis_fmt = lc $synopsis;
+ # made a fuzzy match
+ $pkg_fmt =~ s/[-_]/ /g;
+ $synopsis_fmt =~ s{[-_/\\]}{ }g;
+ $synopsis_fmt =~ s/\s+/ /g;
+ if ($pkg_fmt eq $synopsis_fmt) {
+ $self->hint('description-is-pkg-name', $synopsis);
+ }
+
+ $self->hint('synopsis-too-long')
+ if length $synopsis > $MAXIMUM_WIDTH;
+ }
+
+ my $PLANNED_FEATURES= $self->data->load('description/planned-features');
+
+ my $flagged_homepage;
+ my @lines = split(/\n/, $extended);
+
+ # count starts for extended description
+ my $position = 1;
+ for my $line (@lines) {
+ next
+ if $line =~ /^ \.\s*$/;
+
+ if ($position == 1) {
+ my $firstline = lc $line;
+ my $lsyn = lc $synopsis;
+ if ($firstline =~ /^\Q$lsyn\E$/) {
+ $self->hint('description-synopsis-is-duplicated',
+ "line $position");
+ } else {
+ $firstline =~ s/[^a-zA-Z0-9]+//g;
+ $lsyn =~ s/[^a-zA-Z0-9]+//g;
+ if ($firstline eq $lsyn) {
+ $self->hint('description-synopsis-is-duplicated',
+ "line $position");
+ }
+ }
+ }
+
+ if ($line =~ /^ \.\s*\S/ || $line =~ /^ \s+\.\s*$/) {
+ $self->hint('description-contains-invalid-control-statement',
+ "line $position");
+ } elsif ($line =~ /^ [\-\*]/) {
+ # Print it only the second time. Just one is not enough to be sure that
+ # it's a list, and after the second there's no need to repeat it.
+ $self->hint('possible-unindented-list-in-extended-description',
+ "line $position")
+ if $unindented_list++ == 2;
+ }
+
+ if ($line =~ /\t/) {
+ $self->hint('description-contains-tabs', "line $position")
+ unless $tabs++;
+ }
+
+ if ($line =~ m{^\s*Homepage: <?https?://}i) {
+ $self->hint('description-contains-homepage', "line $position");
+ $flagged_homepage = 1;
+ }
+
+ if ($PLANNED_FEATURES->matches_any($line, 'i')) {
+ $self->hint('description-mentions-planned-features',
+ "(line $position)");
+ }
+
+ $self->hint('odd-mark-in-description',
+ "comma not followed by whitespace (line $position)")
+ if $line =~ /,[^\s\d]/;
+
+ $self->hint('description-contains-dh-make-perl-template',
+ "line $position")
+ if lc($line) =~ / \Q$DH_MAKE_PERL_TEMPLATE\E /msx;
+
+ my $first_person = $line;
+ my %seen;
+ while ($first_person
+ =~ m/(?:^|\s)(I|[Mm]y|[Oo]urs?|mine|myself|me|us|[Ww]e)(?:$|\s)/) {
+ my $word = $1;
+ $first_person =~ s/\Q$word//;
+ $self->hint('using-first-person-in-description',
+ "line $position: $word")
+ unless $seen{$word}++;
+ }
+
+ if ($position == 1) {
+ # checks for the first line of the extended description:
+ if ($line =~ /^ \s/) {
+ $self->hint('description-starts-with-leading-spaces',
+ "line $position");
+ }
+ if ($line =~ /^\s*missing\s*$/i) {
+ $self->hint('description-is-debmake-template',"line $position")
+ unless $template++;
+ } elsif (
+ $line =~ /<insert long description, indented with spaces>/) {
+ $self->hint('description-is-dh_make-template',"line $position")
+ unless $template++;
+ }
+ }
+
+ $self->hint('extended-description-line-too-long', "line $position")
+ if length $line > $MAXIMUM_WIDTH;
+
+ } continue {
+ ++$position;
+ }
+
+ if ($type ne 'udeb') {
+ if (@lines == 0) {
+ # Ignore debug packages with empty "extended" description
+ # "debug symbols for pkg foo" is generally descriptive
+ # enough.
+ $self->hint('extended-description-is-empty')
+ unless $processable->is_debug_package;
+
+ } elsif (@lines < 2 && $synopsis !~ /(?:dummy|transition)/i) {
+ $self->hint('extended-description-is-probably-too-short')
+ unless $processable->is_transitional
+ || $processable->is_meta_package
+ || $pkg =~ m{-dbg\Z}xsm;
+
+ } elsif ($extended =~ /^ \.\s*\n|\n \.\s*\n \.\s*\n|\n \.\s*\n?$/) {
+ $self->hint('extended-description-contains-empty-paragraph');
+ }
+ }
+
+ # Check for a package homepage in the description and no Homepage
+ # field. This is less accurate and more of a guess than looking
+ # for the old Homepage: convention in the body.
+ unless ($processable->fields->declares('Homepage') or $flagged_homepage) {
+ if (
+ $extended =~ m{homepage|webpage|website|url|upstream|web\s+site
+ |home\s+page|further\s+information|more\s+info
+ |official\s+site|project\s+home}xi
+ && $extended =~ m{\b(https?://[a-z0-9][^>\s]+)}i
+ ) {
+ $self->hint('description-possibly-contains-homepage', $1);
+ } elsif ($extended =~ m{\b(https?://[a-z0-9][^>\s]+)>?\.?\s*\z}i) {
+ $self->hint('description-possibly-contains-homepage', $1);
+ }
+ }
+
+ if ($synopsis) {
+ check_spelling(
+ $self->data,
+ $synopsis,
+ $group->spelling_exceptions,
+ $self->spelling_tag_emitter(
+ 'spelling-error-in-description-synopsis')
+ );
+ # Auto-generated dbgsym packages will use the package name in
+ # their synopsis. Unfortunately, some package names trigger a
+ # capitalization error, such as "dbus" -> "D-Bus". Therefore,
+ # we exempt auto-generated packages from this check.
+ check_spelling_picky(
+ $self->data,
+ $synopsis,
+ $self->spelling_tag_emitter(
+ 'capitalization-error-in-description-synopsis')
+ ) unless $processable->is_auto_generated;
+ }
+
+ if ($extended) {
+ check_spelling(
+ $self->data,$extended,
+ $group->spelling_exceptions,
+ $self->spelling_tag_emitter('spelling-error-in-description')
+ );
+ check_spelling_picky($self->data, $extended,
+ $self->spelling_tag_emitter('capitalization-error-in-description')
+ );
+ }
+
+ if ($pkg =~ /^lib(.+)-perl$/) {
+ my $mod = $1;
+ my @mod_path_elements = split(/-/, $mod);
+ $mod = join($DOUBLE_COLON, map {ucfirst} @mod_path_elements);
+ my $mod_lc = lc($mod);
+
+ my $pm_found = 0;
+ my $pmpath = join($SLASH, @mod_path_elements).'.pm';
+ my $pm = $mod_path_elements[-1].'.pm';
+
+ for my $filepath (@{$processable->installed->sorted_list}) {
+ if ($filepath =~ m{\Q$pmpath\E\z|/\Q$pm\E\z}i) {
+ $pm_found = 1;
+ last;
+ }
+ }
+
+ $self->hint('perl-module-name-not-mentioned-in-description', $mod)
+ if (index(lc($extended), $mod_lc) < 0 and $pm_found);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Distribution.pm b/lib/Lintian/Check/Fields/Distribution.pm
new file mode 100644
index 0000000..85390dc
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Distribution.pm
@@ -0,0 +1,167 @@
+# fields/distribution -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software. It is distributed under the terms of
+# the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any
+# later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Distribution;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+sub changes {
+ my ($self) = @_;
+
+ my @distributions
+ = $self->processable->fields->trimmed_list('Distribution');
+
+ $self->hint('multiple-distributions-in-changes-file',
+ join($SPACE, @distributions))
+ if @distributions > 1;
+
+ my @targets = grep { $_ ne 'UNRELEASED' } @distributions;
+
+ # Strip common "extensions" for distributions
+ # (except sid and experimental, where they would
+ # make no sense)
+ my %major;
+ for my $target (@targets) {
+
+ my $reduced = $target;
+ $reduced =~ s{- (?:backports(?:-(?:sloppy|staging))?
+ |lts
+ |proposed(?:-updates)?
+ |updates
+ |security
+ |volatile
+ |fasttrack)$}{}xsm;
+
+ $major{$target} = $reduced;
+ }
+
+ my $KNOWN_DISTS = $self->data->load('changes-file/known-dists');
+
+ my @unknown = grep { !$KNOWN_DISTS->recognizes($major{$_}) } @targets;
+ $self->hint('bad-distribution-in-changes-file', $_) for @unknown;
+
+ my @new_version = qw(sid unstable experimental);
+ my $upload_lc = List::Compare->new(\@targets, \@new_version);
+
+ my @regular = $upload_lc->get_intersection;
+ my @special = $upload_lc->get_Lonly;
+
+ # from Parse/DebianChangelog.pm
+ # the changelog entries in the changes file are in a
+ # different format than in the changelog, so the standard
+ # parsers don't work. We just need to know if there is
+ # info for more than 1 entry, so we just copy part of the
+ # parse code here
+ my $changes = $self->processable->fields->value('Changes');
+
+ # count occurrences
+ my @changes_versions
+ = ($changes =~/^(?: \.)?\s*\S+\s+\(([^\(\)]+)\)\s+\S+/mg);
+
+ my $version = $self->processable->fields->value('Version');
+ my $distnumber;
+ my $bpoversion;
+ if ($version=~ /~bpo(\d+)\+(\d+)(\+salsaci(\+\d+)*)?$/) {
+ $distnumber = $1;
+ $bpoversion = $2;
+
+ $self->hint('upload-has-backports-version-number', $version, $_)
+ for @regular;
+ }
+
+ my @backports = grep { /backports/ } @targets;
+ for my $target (@backports) {
+
+ $self->hint('backports-upload-has-incorrect-version-number',
+ $version, $target)
+ if (!defined $distnumber || !defined $bpoversion)
+ || ($major{$target} eq 'squeeze' && $distnumber ne '60')
+ || ($target eq 'wheezy-backports' && $distnumber ne '70')
+ || ($target eq 'wheezy-backports-sloppy' && $distnumber ne '7')
+ || ($major{$target} eq 'jessie' && $distnumber ne '8');
+
+ # for a ~bpoXX+2 or greater version, there
+ # probably will be only a single changelog entry
+ $self->hint('backports-changes-missing')
+ if ($bpoversion // 0) < 2 && @changes_versions == 1;
+ }
+
+ my $first_line = $changes;
+
+ # advance to first non-empty line
+ $first_line =~ s/^\s+//s;
+
+ my $multiple;
+ if ($first_line =~ /^\s*\S+\s+\([^\(\)]+\)([^;]+);/){
+ $multiple = $1;
+ }
+
+ my @changesdists = split($SPACE, $multiple // $EMPTY);
+ return
+ unless @changesdists;
+
+ # issue only when not mentioned in the Distribution field
+ if ((any { $_ eq 'UNRELEASED' } @changesdists)
+ && none { $_ eq 'UNRELEASED' } @distributions) {
+
+ $self->hint('unreleased-changes');
+ return;
+ }
+
+ my $mismatch_lc = List::Compare->new(\@distributions, \@changesdists);
+ my @from_distribution = $mismatch_lc->get_Lonly;
+ my @from_changes = $mismatch_lc->get_Ronly;
+
+ if (@from_distribution || @from_changes) {
+
+ if (any { $_ eq 'experimental' } @from_changes) {
+ $self->hint('distribution-and-experimental-mismatch');
+
+ } else {
+ $self->hint('distribution-and-changes-mismatch',
+ join($SPACE, @from_distribution, @from_changes));
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/DmUploadAllowed.pm b/lib/Lintian/Check/Fields/DmUploadAllowed.pm
new file mode 100644
index 0000000..6670587
--- /dev/null
+++ b/lib/Lintian/Check/Fields/DmUploadAllowed.pm
@@ -0,0 +1,60 @@
+# fields/dm-upload-allowed -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::DmUploadAllowed;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('DM-Upload-Allowed');
+
+ $self->hint('dm-upload-allowed-is-obsolete');
+
+ my $dmupload = $fields->unfolded_value('DM-Upload-Allowed');
+
+ $self->hint('malformed-dm-upload-allowed', $dmupload)
+ unless $dmupload eq 'yes';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Empty.pm b/lib/Lintian/Check/Fields/Empty.pm
new file mode 100644
index 0000000..184acd3
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Empty.pm
@@ -0,0 +1,49 @@
+# fields/empty -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Empty;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my @all = $self->processable->fields->names;
+ my @empty = grep { !length $self->processable->fields->value($_) } @all;
+
+ $self->hint('empty-field', $_) for @empty;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Essential.pm b/lib/Lintian/Check/Fields/Essential.pm
new file mode 100644
index 0000000..87d43c3
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Essential.pm
@@ -0,0 +1,79 @@
+# fields/essential -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Essential;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ $self->hint('essential-in-source-package')
+ if $fields->declares('Essential');
+
+ return;
+}
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Essential');
+
+ my $essential = $fields->unfolded_value('Essential');
+
+ unless ($essential eq 'yes' || $essential eq 'no') {
+ $self->hint('unknown-essential-value');
+ return;
+ }
+
+ $self->hint('essential-no-not-needed') if $essential eq 'no';
+
+ my $KNOWN_ESSENTIAL = $self->data->load('fields/essential');
+
+ $self->hint('new-essential-package')
+ if $essential eq 'yes'
+ && !$KNOWN_ESSENTIAL->recognizes($self->processable->name);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Format.pm b/lib/Lintian/Check/Fields/Format.pm
new file mode 100644
index 0000000..2d7494a
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Format.pm
@@ -0,0 +1,78 @@
+# fields/format -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Format;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my @supported_source_formats = (qr/1\.0/, qr/3\.0\s*\((quilt|native)\)/);
+
+sub source {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->fields->declares('Format');
+
+ my $format = $self->processable->fields->unfolded_value('Format');
+
+ my $supported = 0;
+ for my $f (@supported_source_formats){
+
+ $supported = 1
+ if $format =~ /^\s*$f\s*\z/;
+ }
+
+ $self->hint('unsupported-source-format', $format) unless $supported;
+
+ return;
+}
+
+sub changes {
+ my ($self) = @_;
+
+ my $format = $self->processable->fields->unfolded_value('Format');
+
+ # without a Format field something is wrong
+ unless (length $format) {
+ $self->hint('malformed-changes-file');
+ return;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Homepage.pm b/lib/Lintian/Check/Fields/Homepage.pm
new file mode 100644
index 0000000..6e2ae87
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Homepage.pm
@@ -0,0 +1,101 @@
+# fields/homepage -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Homepage;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ if $self->processable->native;
+
+ my $debian_control = $self->processable->debian_control;
+
+ my @binaries_with_homepage_field
+ = grep { $debian_control->installable_fields($_)->declares('Homepage') }
+ $debian_control->installables;
+
+ if (!$self->processable->fields->declares('Homepage')) {
+
+ $self->hint('homepage-in-binary-package', $_)
+ for @binaries_with_homepage_field;
+ }
+
+ $self->hint('no-homepage-field')
+ unless @binaries_with_homepage_field
+ || $self->processable->fields->declares('Homepage');
+
+ return;
+}
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Homepage');
+
+ my $homepage = $fields->unfolded_value('Homepage');
+
+ my $orig = $fields->value('Homepage');
+
+ if ($homepage =~ /^<(?:UR[LI]:)?.*>$/i) {
+ $self->hint('superfluous-clutter-in-homepage', $orig);
+ $homepage = substr($homepage, 1, length($homepage) - 2);
+ }
+
+ require URI;
+ my $uri = URI->new($homepage);
+
+ # not an absolute URI or (most likely) an invalid protocol
+ $self->hint('bad-homepage', $orig)
+ unless $uri->scheme && $uri->scheme =~ /^(?:ftp|https?|gopher)$/;
+
+ my $BAD_HOMEPAGES = $self->data->load('fields/bad-homepages');
+
+ foreach my $line ($BAD_HOMEPAGES->all) {
+ my ($tag, $re) = split(/\s*~~\s*/, $line);
+ $self->hint($tag, $orig) if $homepage =~ m/$re/;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/InstallerMenuItem.pm b/lib/Lintian/Check/Fields/InstallerMenuItem.pm
new file mode 100644
index 0000000..2b799d3
--- /dev/null
+++ b/lib/Lintian/Check/Fields/InstallerMenuItem.pm
@@ -0,0 +1,59 @@
+# fields/installer-menu-item -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::InstallerMenuItem;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub udeb {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ #---- Installer-Menu-Item (udeb)
+
+ return
+ unless $fields->declares('Installer-Menu-Item');
+
+ my $menu_item = $fields->unfolded_value('Installer-Menu-Item');
+
+ $self->hint('bad-menu-item', $menu_item) unless $menu_item =~ /^\d+$/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Length.pm b/lib/Lintian/Check/Fields/Length.pm
new file mode 100644
index 0000000..e9765bd
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Length.pm
@@ -0,0 +1,86 @@
+# fields/length -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2019 Sylvestre Ledru
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Length;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $MAXIMUM_LENGTH => 5_000;
+
+my @ALLOWED_FIELDS = qw(
+ Build-Ids
+ Description
+ Package-List
+ Installed-Build-Depends
+ Checksums-Sha256
+);
+
+sub always {
+ my ($self) = @_;
+
+ return
+ if any { $self->processable->type eq $_ } qw(changes buildinfo);
+
+ # all fields
+ my @all = $self->processable->fields->names;
+
+ # longer than maximum
+ my @long= grep {
+ length $self->processable->fields->untrimmed_value($_)> $MAXIMUM_LENGTH
+ }@all;
+
+ # filter allowed fields
+ my $allowedlc = List::Compare->new(\@long, \@ALLOWED_FIELDS);
+ my @too_long = $allowedlc->get_Lonly;
+
+ for my $name (@too_long) {
+
+ my $length = length $self->processable->fields->value($name);
+
+ $self->hint('field-too-long', $name,
+ "($length chars > $MAXIMUM_LENGTH)");
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/MailAddress.pm b/lib/Lintian/Check/Fields/MailAddress.pm
new file mode 100644
index 0000000..02fd5f1
--- /dev/null
+++ b/lib/Lintian/Check/Fields/MailAddress.pm
@@ -0,0 +1,150 @@
+# fields/mail-address -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Felix Lechner
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::MailAddress;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Data::Validate::Domain;
+use Email::Address::XS;
+use List::SomeUtils qw(any all);
+use List::UtilsBy qw(uniq_by);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $QA_GROUP_PHRASE => 'Debian QA Group';
+const my $QA_GROUP_ADDRESS => 'packages@qa.debian.org';
+const my $ARROW => q{ -> };
+
+# list of addresses known to bounce messages from role accounts
+my @KNOWN_BOUNCE_ADDRESSES = qw(
+ ubuntu-devel-discuss@lists.ubuntu.com
+);
+
+sub always {
+ my ($self) = @_;
+
+ my @singles = qw(Maintainer Changed-By);
+ my @groups = qw(Uploaders);
+
+ my @singles_present
+ = grep { $self->processable->fields->declares($_) } @singles;
+ my @groups_present
+ = grep { $self->processable->fields->declares($_) } @groups;
+
+ my %parsed;
+ for my $role (@singles_present, @groups_present) {
+
+ my $value = $self->processable->fields->value($role);
+ $parsed{$role} = [Email::Address::XS->parse($value)];
+ }
+
+ for my $role (keys %parsed) {
+
+ my @invalid = grep { !$_->is_valid } @{$parsed{$role}};
+ $self->hint('malformed-contact', $role, $_->original)for @invalid;
+
+ my @valid = grep { $_->is_valid } @{$parsed{$role}};
+ my @unique = uniq_by { $_->format } @valid;
+
+ $self->check_single_address($role, $_) for @unique;
+ }
+
+ for my $role (@singles_present) {
+ $self->hint('too-many-contacts', $role,
+ $self->processable->fields->value($role))
+ if @{$parsed{$role}} > 1;
+ }
+
+ for my $role (@groups_present) {
+ my @valid = grep { $_->is_valid } @{$parsed{$role}};
+ my @addresses = map { $_->address } @valid;
+
+ my %count;
+ $count{$_}++ for @addresses;
+ my @duplicates = grep { $count{$_} > 1 } keys %count;
+
+ $self->hint('duplicate-contact', $role, $_) for @duplicates;
+ }
+
+ return;
+}
+
+sub check_single_address {
+ my ($self, $role, $parsed) = @_;
+
+ $self->hint('mail-contact', $role, $parsed->format);
+
+ unless (all { length } ($parsed->address, $parsed->user, $parsed->host)) {
+ $self->hint('incomplete-mail-address', $role, $parsed->format);
+ return;
+ }
+
+ $self->hint('bogus-mail-host', $role, $parsed->address)
+ unless is_domain($parsed->host, {domain_disable_tld_validation => 1});
+
+ $self->hint('mail-address-loops-or-bounces',$role, $parsed->address)
+ if any { $_ eq $parsed->address } @KNOWN_BOUNCE_ADDRESSES;
+
+ unless (length $parsed->phrase) {
+ $self->hint('no-phrase', $role, $parsed->format);
+ return;
+ }
+
+ $self->hint('root-in-contact', $role, $parsed->format)
+ if $parsed->user eq 'root' || $parsed->phrase eq 'root';
+
+ # Debian QA Group
+ $self->hint('faulty-debian-qa-group-phrase',
+ $role, $parsed->phrase . $ARROW . $QA_GROUP_PHRASE)
+ if $parsed->address eq $QA_GROUP_ADDRESS
+ && $parsed->phrase ne $QA_GROUP_PHRASE;
+
+ $self->hint('faulty-debian-qa-group-address',
+ $role, $parsed->address . $ARROW . $QA_GROUP_ADDRESS)
+ if ( $parsed->phrase =~ /\bdebian\s+qa\b/i
+ && $parsed->address ne $QA_GROUP_ADDRESS)
+ || $parsed->address eq 'debian-qa@lists.debian.org';
+
+ $self->hint('mailing-list-on-alioth', $role, $parsed->address)
+ if $parsed->host eq 'lists.alioth.debian.org';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Maintainer.pm b/lib/Lintian/Check/Fields/Maintainer.pm
new file mode 100644
index 0000000..7267092
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Maintainer.pm
@@ -0,0 +1,84 @@
+# fields/maintainer -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Felix Lechner
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Maintainer;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->fields->declares('Maintainer');
+
+ my $maintainer = $self->processable->fields->value('Maintainer');
+
+ my $is_list = $maintainer =~ /\@lists(?:\.alioth)?\.debian\.org\b/;
+
+ $self->hint('no-human-maintainers')
+ if $is_list && !$self->processable->fields->declares('Uploaders');
+
+ return;
+}
+
+sub changes {
+ my ($self) = @_;
+
+ my $source = $self->group->source;
+ return
+ unless defined $source;
+
+ my $changes_maintainer = $self->processable->fields->value('Maintainer');
+ my $changes_distribution
+ = $self->processable->fields->value('Distribution');
+
+ my $source_maintainer = $source->fields->value('Maintainer');
+
+ my $KNOWN_DISTS = $self->data->load('changes-file/known-dists');
+
+ # not for derivatives; https://wiki.ubuntu.com/DebianMaintainerField
+ $self->hint('inconsistent-maintainer',
+ $changes_maintainer . ' (changes vs. source) ' .$source_maintainer)
+ if $changes_maintainer ne $source_maintainer
+ && $KNOWN_DISTS->recognizes($changes_distribution);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Maintainer/Team.pm b/lib/Lintian/Check/Fields/Maintainer/Team.pm
new file mode 100644
index 0000000..b068d9f
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Maintainer/Team.pm
@@ -0,0 +1,90 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Maintainer::Team;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Email::Address::XS;
+use List::SomeUtils qw(uniq first_value);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $ARROW => qq{ \N{RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK} };
+
+my %team_names = (
+ 'debian-go@lists.debian.org' => 'golang',
+ 'debian-clojure@lists.debian.org' => 'clojure',
+ 'pkg-java-maintainers@lists.alioth.debian.org' => 'java',
+ 'pkg-javascript-maintainers@lists.alioth.debian.org' => 'javascript',
+ 'pkg-perl-maintainers@lists.alioth.debian.org' => 'perl',
+ 'team+python@tracker.debian.org' => 'python'
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $maintainer = $self->processable->fields->value('Maintainer');
+ return
+ unless length $maintainer;
+
+ my $parsed = Email::Address::XS->parse($maintainer);
+ return
+ unless $parsed->is_valid;
+
+ return
+ unless length $parsed->address;
+
+ my $team = $team_names{$parsed->address};
+ return
+ unless length $team;
+
+ return
+ if $self->name_contains($team);
+
+ my @other_teams = uniq grep { $_ ne $team } values %team_names;
+
+ my $name_suggests = first_value { $self->name_contains($_) } @other_teams;
+ return
+ unless length $name_suggests;
+
+ $self->hint('wrong-team', $team . $ARROW . $name_suggests)
+ unless $name_suggests eq $team;
+
+ return;
+}
+
+sub name_contains {
+ my ($self, $string) = @_;
+
+ return $self->processable->name =~ m{ \b \Q$string\E \b }sx;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/MultiArch.pm b/lib/Lintian/Check/Fields/MultiArch.pm
new file mode 100644
index 0000000..5b42f9f
--- /dev/null
+++ b/lib/Lintian/Check/Fields/MultiArch.pm
@@ -0,0 +1,138 @@
+# fields/multi-arch -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::MultiArch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(uniq any);
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+sub source {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+
+ for my $bin ($processable->debian_control->installables) {
+
+ next
+ unless ($processable->debian_control->installable_fields($bin)
+ ->value('Multi-Arch')) eq 'same';
+
+ my $wildcard = $processable->debian_control->installable_fields($bin)
+ ->value('Architecture');
+ my @arches = split(
+ $SPACE,
+ decode_utf8(
+ safe_qx(
+ 'dpkg-architecture', '--match-wildcard',
+ $wildcard, '--list-known'
+ )
+ )
+ );
+
+ # include original wildcard
+ push(@arches, $wildcard);
+
+ for my $port (uniq @arches) {
+
+ my $specific = $processable->patched->resolve_path(
+ "debian/$bin.lintian-overrides.$port");
+ next
+ unless defined $specific;
+
+ $self->pointed_hint(
+ 'multi-arch-same-package-has-arch-specific-overrides',
+ $specific->pointer);
+ }
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ if ($self->processable->name =~ /^x?fonts-/) {
+
+ my $multi = $fields->value('Multi-Arch') || 'no';
+
+ $self->hint('font-package-not-multi-arch-foreign')
+ unless any { $multi eq $_ } qw(foreign allowed);
+ }
+
+ return
+ unless $fields->declares('Multi-Arch');
+
+ my $multi = $fields->unfolded_value('Multi-Arch');
+
+ if ($fields->declares('Architecture')) {
+
+ my $architecture = $fields->unfolded_value('Architecture');
+
+ $self->hint('illegal-multi-arch-value', $architecture, $multi)
+ if $architecture eq 'all' && $multi eq 'same';
+ }
+
+ return;
+}
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Multi-Arch');
+
+ my $multi = $fields->unfolded_value('Multi-Arch');
+
+ $self->hint('unknown-multi-arch-value', $self->processable->name, $multi)
+ unless any { $multi eq $_ } qw(no foreign allowed same);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/MultiLine.pm b/lib/Lintian/Check/Fields/MultiLine.pm
new file mode 100644
index 0000000..ca31cd5
--- /dev/null
+++ b/lib/Lintian/Check/Fields/MultiLine.pm
@@ -0,0 +1,89 @@
+# fields/multi-line -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2019 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::MultiLine;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $NEWLINE => qq{\n};
+
+# based on policy 5.6
+my @always_single = (
+ qw(Architecture Bugs Changed-By Closes Date Distribution Dm-Upload-Allowed),
+ qw(Essential Format Homepage Installed-Size Installer-Menu-Item Maintainer),
+ qw(Multi-Arch Origin Package Priority Section Source Standards-Version),
+ qw(Subarchitecture Urgency Version)
+);
+
+my @package_relations
+ = (
+ qw(Depends Pre-Depends Recommends Suggests Conflicts Provides Enhances Replaces Breaks)
+ );
+
+sub always {
+ my ($self) = @_;
+
+ my @banned = @always_single;
+
+ # for package relations, multi-line only in source (policy 7.1)
+ push(@banned, @package_relations)
+ unless $self->processable->type eq 'source';
+
+ my @present = $self->processable->fields->names;
+
+ my $single_lc = List::Compare->new(\@present, \@banned);
+ my @enforce = $single_lc->get_intersection;
+
+ for my $name (@enforce) {
+
+ my $value = $self->processable->fields->untrimmed_value($name);
+
+ # remove a final newline, if any
+ $value =~ s/\n$//;
+
+ # check if fields have newlines in them
+ $self->hint('multiline-field', $name)
+ if index($value, $NEWLINE) >= 0;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Origin.pm b/lib/Lintian/Check/Fields/Origin.pm
new file mode 100644
index 0000000..4d36793
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Origin.pm
@@ -0,0 +1,57 @@
+# fields/origin -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Origin;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Origin');
+
+ my $origin = $fields->unfolded_value('Origin');
+
+ $self->hint('redundant-origin-field') if lc($origin) eq 'debian';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Package.pm b/lib/Lintian/Check/Fields/Package.pm
new file mode 100644
index 0000000..2ce436f
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Package.pm
@@ -0,0 +1,61 @@
+# fields/package -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Package;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->fields->declares('Package');
+
+ my $name = $self->processable->fields->unfolded_value('Package');
+
+ $self->hint('bad-package-name') unless $name =~ /^$PKGNAME_REGEX$/i;
+
+ $self->hint('package-not-lowercase') if $name =~ /[A-Z]/;
+
+ $self->hint('unusual-documentation-package-name') if $name =~ /-docs$/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/PackageRelations.pm b/lib/Lintian/Check/Fields/PackageRelations.pm
new file mode 100644
index 0000000..eeb11c0
--- /dev/null
+++ b/lib/Lintian/Check/Fields/PackageRelations.pm
@@ -0,0 +1,794 @@
+# fields/package-relations -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2019-2020 Chris Lamb <lamby@debian.org>
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::PackageRelations;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Dpkg::Version qw(version_check);
+use List::SomeUtils qw(any);
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $EQUAL => q{=};
+const my $VERTICAL_BAR => q{|};
+
+# Still in the archive but shouldn't be the primary Emacs dependency.
+my @obsolete_emacs_versions = qw(21 22 23);
+my @emacs_flavors = ($EMPTY, qw(-el -gtk -nox -lucid));
+my %known_obsolete_emacs;
+for my $version (@obsolete_emacs_versions) {
+ for my $flavor (@emacs_flavors) {
+
+ my $package = 'emacs' . $version . $flavor;
+ $known_obsolete_emacs{$package} = 1;
+ }
+}
+
+my %known_libstdcs = map { $_ => 1 } qw(
+ libstdc++2.9-glibc2.1
+ libstdc++2.10
+ libstdc++2.10-glibc2.2
+ libstdc++3
+ libstdc++3.0
+ libstdc++4
+ libstdc++5
+ libstdc++6
+ lib64stdc++6
+);
+
+my %known_tcls = map { $_ => 1 } qw(
+ tcl74
+ tcl8.0
+ tcl8.2
+ tcl8.3
+ tcl8.4
+ tcl8.5
+);
+
+my %known_tclxs = map { $_ => 1 } qw(
+ tclx76
+ tclx8.0.4
+ tclx8.2
+ tclx8.3
+ tclx8.4
+);
+
+my %known_tks = map { $_ => 1 } qw(
+ tk40
+ tk8.0
+ tk8.2
+ tk8.3
+ tk8.4
+ tk8.5
+);
+
+my %known_libpngs = map { $_ => 1 } qw(
+ libpng12-0
+ libpng2
+ libpng3
+);
+
+my @known_java_pkg = map { qr/$_/ } (
+ 'default-j(?:re|dk)(?:-headless)?',
+ # java-runtime and javaX-runtime alternatives (virtual)
+ 'java\d*-runtime(?:-headless)?',
+ # openjdk-X and sun-javaX
+ '(openjdk-|sun-java)\d+-j(?:re|dk)(?:-headless)?',
+ 'gcj-(?:\d+\.\d+-)?jre(?:-headless)?', 'gcj-(?:\d+\.\d+-)?jdk', # gcj
+ 'gij',
+ 'java-gcj-compat(?:-dev|-headless)?', # deprecated/transitional packages
+ 'kaffe', 'cacao', 'jamvm',
+ 'classpath', # deprecated packages (removed in Squeeze)
+);
+
+# Python development packages that are used almost always just for building
+# architecture-dependent modules. Used to check for unnecessary build
+# dependencies for architecture-independent source packages.
+our $PYTHON_DEV = join(' | ',
+ qw(python3-dev python3-all-dev),
+ map { "python$_-dev:any" } qw(2.7 3 3.7 3.8 3.9));
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $type = $self->processable->type;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my $KNOWN_ESSENTIAL = $self->data->load('fields/essential');
+ my $KNOWN_TOOLCHAIN = $self->data->load('fields/toolchain');
+ my $KNOWN_METAPACKAGES = $self->data->load('fields/metapackages');
+
+ my $DH_ADDONS = $self->data->debhelper_addons;
+ my %DH_ADDONS_VALUES
+ = map { $_ => 1 } map { $DH_ADDONS->installed_by($_) } $DH_ADDONS->all;
+
+ my $OBSOLETE_PACKAGES
+ = $self->data->load('fields/obsolete-packages',qr/\s*=>\s*/);
+
+ my $VIRTUAL_PACKAGES= $self->data->load('fields/virtual-packages');
+
+ my $javalib = 0;
+ my $replaces = $processable->relation('Replaces');
+ my %nag_once;
+ $javalib = 1 if($pkg =~ m/^lib.*-java$/);
+ for my $field (
+ qw(Depends Pre-Depends Recommends Suggests Conflicts Provides Enhances Replaces Breaks)
+ ) {
+ next
+ unless $processable->fields->declares($field);
+
+ # get data and clean it
+ my $data = $processable->fields->unfolded_value($field);
+ my $javadep = 0;
+
+ my (@seen_libstdcs, @seen_tcls, @seen_tclxs,@seen_tks, @seen_libpngs);
+
+ my $is_dep_field
+ = any { $field eq $_ } qw(Depends Pre-Depends Recommends Suggests);
+
+ $self->hint('alternates-not-allowed', $field)
+ if ($data =~ /\|/ && !$is_dep_field);
+ $self->check_field($field, $data) if $is_dep_field;
+
+ for my $dep (split /\s*,\s*/, $data) {
+ my (@alternatives, @seen_obsolete_packages);
+ push @alternatives, [_split_dep($_), $_]
+ for (split /\s*\|\s*/, $dep);
+
+ if ($is_dep_field) {
+ push @seen_libstdcs, $alternatives[0][0]
+ if defined $known_libstdcs{$alternatives[0][0]};
+ push @seen_tcls, $alternatives[0][0]
+ if defined $known_tcls{$alternatives[0][0]};
+ push @seen_tclxs, $alternatives[0][0]
+ if defined $known_tclxs{$alternatives[0][0]};
+ push @seen_tks, $alternatives[0][0]
+ if defined $known_tks{$alternatives[0][0]};
+ push @seen_libpngs, $alternatives[0][0]
+ if defined $known_libpngs{$alternatives[0][0]};
+ }
+
+ # Only for (Pre-)?Depends.
+ $self->hint('virtual-package-depends-without-real-package-depends',
+ "$field: $alternatives[0][0]")
+ if (
+ $VIRTUAL_PACKAGES->recognizes($alternatives[0][0])
+ && ($field eq 'Depends' || $field eq 'Pre-Depends')
+ && ($pkg ne 'base-files' || $alternatives[0][0] ne 'awk')
+ # ignore phpapi- dependencies as adding an
+ # alternative, real, package breaks its purpose
+ && $alternatives[0][0] !~ m/^phpapi-/
+ );
+
+ # Check defaults for transitions. Here, we only care
+ # that the first alternative is current.
+ $self->hint('depends-on-old-emacs', "$field: $alternatives[0][0]")
+ if ( $is_dep_field
+ && $known_obsolete_emacs{$alternatives[0][0]});
+
+ for my $part_d (@alternatives) {
+ my ($d_pkg, $d_march, $d_version, undef, undef, $rest,
+ $part_d_orig)
+ = @{$part_d};
+
+ $self->hint('invalid-versioned-provides', $part_d_orig)
+ if ( $field eq 'Provides'
+ && $d_version->[0]
+ && $d_version->[0] ne $EQUAL);
+
+ $self->hint('bad-provided-package-name', $d_pkg)
+ if $d_pkg !~ /^[a-z0-9][-+\.a-z0-9]+$/;
+
+ $self->hint('breaks-without-version', $part_d_orig)
+ if ( $field eq 'Breaks'
+ && !$d_version->[0]
+ && !$VIRTUAL_PACKAGES->recognizes($d_pkg)
+ && !$replaces->satisfies($part_d_orig));
+
+ $self->hint('conflicts-with-version', $part_d_orig)
+ if ($field eq 'Conflicts' && $d_version->[0]);
+
+ $self->hint('obsolete-relation-form', "$field: $part_d_orig")
+ if ($d_version && any { $d_version->[0] eq $_ }('<', '>'));
+
+ $self->hint('bad-version-in-relation', "$field: $part_d_orig")
+ if ($d_version->[0] && !version_check($d_version->[1]));
+
+ $self->hint('package-relation-with-self',
+ "$field: $part_d_orig")
+ if ($pkg eq $d_pkg)
+ && (!$d_march)
+ && ( $field ne 'Conflicts'
+ && $field ne 'Replaces'
+ && $field ne 'Provides');
+
+ $self->hint('bad-relation', "$field: $part_d_orig") if $rest;
+
+ push @seen_obsolete_packages, [$part_d_orig, $d_pkg]
+ if ( $OBSOLETE_PACKAGES->recognizes($d_pkg)
+ && $is_dep_field);
+
+ $self->hint('depends-on-metapackage', "$field: $part_d_orig")
+ if ( $KNOWN_METAPACKAGES->recognizes($d_pkg)
+ && !$KNOWN_METAPACKAGES->recognizes($pkg)
+ && !$processable->is_transitional
+ && !$processable->is_meta_package
+ && $is_dep_field);
+
+ # diffutils is a special case since diff was
+ # renamed to diffutils, so a dependency on
+ # diffutils effectively is a versioned one.
+ $self->hint(
+ 'depends-on-essential-package-without-using-version',
+ "$field: $part_d_orig")
+ if ( $KNOWN_ESSENTIAL->recognizes($d_pkg)
+ && !$d_version->[0]
+ && $is_dep_field
+ && $d_pkg ne 'diffutils'
+ && $d_pkg ne 'dash');
+
+ $self->hint('package-depends-on-an-x-font-package',
+ "$field: $part_d_orig")
+ if ( $field =~ /^(?:Pre-)?Depends$/
+ && $d_pkg =~ /^xfont.*/
+ && $d_pkg ne 'xfonts-utils'
+ && $d_pkg ne 'xfonts-encodings');
+
+ $self->hint('depends-on-packaging-dev',$field)
+ if (($field =~ /^(?:Pre-)?Depends$/|| $field eq 'Recommends')
+ && $d_pkg eq 'packaging-dev'
+ && !$processable->is_transitional
+ && !$processable->is_meta_package);
+
+ $self->hint('needless-suggest-recommend-libservlet-java',
+ "$d_pkg")
+ if (($field eq 'Recommends' || $field eq 'Suggests')
+ && $d_pkg =~ m/libservlet[\d\.]+-java/);
+
+ $self->hint('needlessly-depends-on-awk', $field)
+ if ( $d_pkg eq 'awk'
+ && !$d_version->[0]
+ && $is_dep_field
+ && $pkg ne 'base-files');
+
+ $self->hint('depends-on-libdb1-compat', $field)
+ if ( $d_pkg eq 'libdb1-compat'
+ && $pkg !~ /^libc(?:6|6.1|0.3)/
+ && $field =~ /^(?:Pre-)?Depends$/);
+
+ $self->hint('depends-on-python-minimal', $field,)
+ if ( $d_pkg =~ /^python[\d.]*-minimal$/
+ && $is_dep_field
+ && $pkg !~ /^python[\d.]*-minimal$/);
+
+ $self->hint('doc-package-depends-on-main-package', $field)
+ if ("$d_pkg-doc" eq $pkg
+ && $field =~ /^(?:Pre-)?Depends$/);
+
+ $self->hint(
+ 'package-relation-with-perl-modules', "$field: $d_pkg"
+ # matches "perl-modules" (<= 5.20) as well as
+ # perl-modules-5.xx (>> 5.20)
+ )
+ if $d_pkg =~ /^perl-modules/
+ && $field ne 'Replaces'
+ && $processable->source_name ne 'perl';
+
+ $self->hint('depends-exclusively-on-makedev', $field,)
+ if ( $field eq 'Depends'
+ && $d_pkg eq 'makedev'
+ && @alternatives == 1);
+
+ $self->hint('lib-recommends-documentation',
+ "$field: $part_d_orig")
+ if ( $field eq 'Recommends'
+ && $pkg =~ m/^lib/
+ && $pkg !~ m/-(?:dev|docs?|tools|bin)$/
+ && $part_d_orig =~ m/-docs?$/);
+
+ $self->hint('binary-package-depends-on-toolchain-package',
+ "$field: $part_d_orig")
+ if $KNOWN_TOOLCHAIN->recognizes($d_pkg)
+ && $is_dep_field
+ && $pkg !~ /^dh-/
+ && $pkg !~ /-(?:source|src)$/
+ && !$processable->is_transitional
+ && !$processable->is_meta_package
+ && !$DH_ADDONS_VALUES{$pkg};
+
+ # default-jdk-doc must depend on openjdk-X-doc (or
+ # classpath-doc) to be useful; other packages
+ # should depend on default-jdk-doc if they want
+ # the Java Core API.
+ $self->hint('depends-on-specific-java-doc-package',$field)
+ if (
+ $is_dep_field
+ && $pkg ne 'default-jdk-doc'
+ && ( $d_pkg eq 'classpath-doc'
+ || $d_pkg =~ /openjdk-\d+-doc/)
+ );
+
+ if ($javalib && $field eq 'Depends'){
+ foreach my $reg (@known_java_pkg){
+ if($d_pkg =~ m/$reg/){
+ $javadep++;
+ last;
+ }
+
+ }
+ }
+ }
+
+ for my $d (@seen_obsolete_packages) {
+ my ($dep, $pkg_name) = @{$d};
+ my $replacement = $OBSOLETE_PACKAGES->value($pkg_name)
+ // $EMPTY;
+ $replacement = ' => ' . $replacement
+ if $replacement ne $EMPTY;
+ if ($pkg_name eq $alternatives[0][0]
+ or scalar @seen_obsolete_packages== scalar @alternatives) {
+ $self->hint(
+ 'depends-on-obsolete-package',
+ "$field: $dep${replacement}"
+ );
+ } else {
+ $self->hint(
+ 'ored-depends-on-obsolete-package',
+ "$field: $dep${replacement}"
+ );
+ }
+ }
+
+ # Only emit the tag if all the alternatives are
+ # JVM/JRE/JDKs
+ # - assume that <some-lib> | openjdk-X-jre-headless
+ # makes sense for now.
+ if (scalar(@alternatives) == $javadep
+ && !exists $nag_once{'needless-dependency-on-jre'}){
+ $nag_once{'needless-dependency-on-jre'} = 1;
+ $self->hint('needless-dependency-on-jre');
+ }
+ }
+ $self->hint('package-depends-on-multiple-libstdc-versions',
+ @seen_libstdcs)
+ if (scalar @seen_libstdcs > 1);
+ $self->hint('package-depends-on-multiple-tcl-versions', @seen_tcls)
+ if (scalar @seen_tcls > 1);
+ $self->hint('package-depends-on-multiple-tclx-versions', @seen_tclxs)
+ if (scalar @seen_tclxs > 1);
+ $self->hint('package-depends-on-multiple-tk-versions', @seen_tks)
+ if (scalar @seen_tks > 1);
+ $self->hint('package-depends-on-multiple-libpng-versions',
+ @seen_libpngs)
+ if (scalar @seen_libpngs > 1);
+ }
+
+ # If Conflicts or Breaks is set, make sure it's not inconsistent with
+ # the other dependency fields.
+ for my $conflict (qw/Conflicts Breaks/) {
+ next
+ unless $processable->fields->declares($conflict);
+
+ for my $field (qw(Depends Pre-Depends Recommends Suggests)) {
+ next
+ unless $processable->fields->declares($field);
+
+ my $relation = $processable->relation($field);
+ for my $package (split /\s*,\s*/,
+ $processable->fields->value($conflict)) {
+
+ $self->hint('conflicts-with-dependency', $field, $package)
+ if $relation->satisfies($package);
+ }
+ }
+ }
+
+ return;
+}
+
+sub source {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $type = $self->processable->type;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my $KNOWN_ESSENTIAL = $self->data->load('fields/essential');
+ my $KNOWN_METAPACKAGES = $self->data->load('fields/metapackages');
+ my $NO_BUILD_DEPENDS= $self->data->load('fields/no-build-depends');
+ my $known_build_essential
+ = $self->data->load('fields/build-essential-packages');
+ my $KNOWN_BUILD_PROFILES= $self->data->load('fields/build-profiles');
+
+ my $OBSOLETE_PACKAGES
+ = $self->data->load('fields/obsolete-packages',qr/\s*=>\s*/);
+
+ my $VIRTUAL_PACKAGES= $self->data->load('fields/virtual-packages');
+
+ my @binpkgs = $processable->debian_control->installables;
+
+ #Get number of arch-indep packages:
+ my $arch_indep_packages = 0;
+ my $arch_dep_packages = 0;
+
+ for my $binpkg (@binpkgs) {
+ my $arch = $processable->debian_control->installable_fields($binpkg)
+ ->value('Architecture');
+
+ if ($arch eq 'all') {
+ $arch_indep_packages++;
+ } else {
+ $arch_dep_packages++;
+ }
+ }
+
+ $self->hint('build-depends-indep-without-arch-indep')
+ if ( $processable->fields->declares('Build-Depends-Indep')
+ && $arch_indep_packages == 0);
+
+ $self->hint('build-depends-arch-without-arch-dependent-binary')
+ if ( $processable->fields->declares('Build-Depends-Arch')
+ && $arch_dep_packages == 0);
+
+ my %depend;
+ for my $field (
+ qw(Build-Depends Build-Depends-Indep Build-Depends-Arch Build-Conflicts Build-Conflicts-Indep Build-Conflicts-Arch)
+ ) {
+ if ($processable->fields->declares($field)) {
+
+ my $is_dep_field = any { $field eq $_ }
+ qw(Build-Depends Build-Depends-Indep Build-Depends-Arch);
+
+ # get data and clean it
+ my $data = $processable->fields->unfolded_value($field);
+
+ $self->check_field($field, $data);
+ $depend{$field} = $data;
+
+ for my $dep (split /\s*,\s*/, $data) {
+ my (@alternatives, @seen_obsolete_packages);
+ push @alternatives, [_split_dep($_), $_]
+ for (split /\s*\|\s*/, $dep);
+
+ $self->hint(
+ 'virtual-package-depends-without-real-package-depends',
+ "$field: $alternatives[0][0]")
+ if ( $VIRTUAL_PACKAGES->recognizes($alternatives[0][0])
+ && $is_dep_field);
+
+ for my $part_d (@alternatives) {
+ my ($d_pkg, undef, $d_version, $d_arch, $d_restr,
+ $rest,$part_d_orig)
+ = @{$part_d};
+
+ for my $arch (@{$d_arch->[0]}) {
+ $self->hint('invalid-arch-string-in-source-relation',
+ $arch, "[$field: $part_d_orig]")
+ if $arch eq 'all'
+ || (
+ !$self->data->architectures
+ ->is_release_architecture(
+ $arch)
+ && !$self->data->architectures->is_wildcard($arch)
+ );
+ }
+
+ for my $restrlist (@{$d_restr}) {
+ for my $prof (@{$restrlist}) {
+ $prof =~ s/^!//;
+ $self->hint(
+ 'invalid-profile-name-in-source-relation',
+ "$prof [$field: $part_d_orig]"
+ )
+ unless $KNOWN_BUILD_PROFILES->recognizes($prof)
+ or $prof =~ /^pkg\.[a-z0-9][a-z0-9+.-]+\../;
+ }
+ }
+
+ if ( $d_pkg =~ /^openjdk-\d+-doc$/
+ or $d_pkg eq 'classpath-doc'){
+ $self->hint(
+ 'build-depends-on-specific-java-doc-package',
+ $d_pkg);
+ }
+
+ if ($d_pkg eq 'java-compiler'){
+ $self->hint(
+ 'build-depends-on-an-obsolete-java-package',
+ $d_pkg);
+ }
+
+ if ( $d_pkg =~ /^libdb\d+\.\d+.*-dev$/
+ and $is_dep_field) {
+ $self->hint('build-depends-on-versioned-berkeley-db',
+ "$field:$d_pkg");
+ }
+
+ $self->hint('conflicting-negation-in-source-relation',
+ "$field: $part_d_orig")
+ if ( $d_arch
+ && $d_arch->[1] != 0
+ && $d_arch->[1] ne @{ $d_arch->[0] });
+
+ $self->hint('depends-on-packaging-dev', $field)
+ if ($d_pkg eq 'packaging-dev');
+
+ $self->hint('build-depends-on-build-essential', $field)
+ if ($d_pkg eq 'build-essential');
+
+ $self->hint(
+'build-depends-on-build-essential-package-without-using-version',
+ "$d_pkg [$field: $part_d_orig]"
+ )
+ if ($known_build_essential->recognizes($d_pkg)
+ && !$d_version->[1]);
+
+ $self->hint(
+'build-depends-on-essential-package-without-using-version',
+ "$field: $part_d_orig"
+ )
+ if ( $KNOWN_ESSENTIAL->recognizes($d_pkg)
+ && !$d_version->[0]
+ && $d_pkg ne 'dash');
+ push @seen_obsolete_packages, [$part_d_orig, $d_pkg]
+ if ( $OBSOLETE_PACKAGES->recognizes($d_pkg)
+ && $is_dep_field);
+
+ $self->hint('build-depends-on-metapackage',
+ "$field: $part_d_orig")
+ if ( $KNOWN_METAPACKAGES->recognizes($d_pkg)
+ and $is_dep_field);
+
+ $self->hint('build-depends-on-non-build-package',
+ "$field: $part_d_orig")
+ if ( $NO_BUILD_DEPENDS->recognizes($d_pkg)
+ and $is_dep_field);
+
+ $self->hint('build-depends-on-1-revision',
+ "$field: $part_d_orig")
+ if ( $d_version->[0] eq '>='
+ && $d_version->[1] =~ /-1$/
+ && $is_dep_field);
+
+ $self->hint('bad-relation', "$field: $part_d_orig")
+ if $rest;
+
+ $self->hint('bad-version-in-relation',
+ "$field: $part_d_orig")
+ if ($d_version->[0]
+ && !version_check($d_version->[1]));
+
+ $self->hint(
+ 'package-relation-with-perl-modules',
+ "$field: $part_d_orig"
+ # matches "perl-modules" (<= 5.20) as well as
+ # perl-modules-5.xx (>> 5.20)
+ )
+ if $d_pkg =~ /^perl-modules/
+ && $processable->source_name ne 'perl';
+ }
+
+ my $all_obsolete = 0;
+ $all_obsolete = 1
+ if scalar @seen_obsolete_packages == @alternatives;
+ for my $d (@seen_obsolete_packages) {
+ my ($dep, $pkg_name) = @{$d};
+ my $replacement = $OBSOLETE_PACKAGES->value($pkg_name)
+ // $EMPTY;
+
+ $replacement = ' => ' . $replacement
+ if $replacement ne $EMPTY;
+ if ( $pkg_name eq $alternatives[0][0]
+ or $all_obsolete) {
+ $self->hint('build-depends-on-obsolete-package',
+ "$field: $dep${replacement}");
+ } else {
+ $self->hint('ored-build-depends-on-obsolete-package',
+ "$field: $dep${replacement}");
+ }
+ }
+ }
+ }
+ }
+
+ # Check for redundancies.
+ my @to_check = (
+ ['Build-Depends'],
+ ['Build-Depends', 'Build-Depends-Indep'],
+ ['Build-Depends', 'Build-Depends-Arch']
+ );
+
+ for my $fields (@to_check) {
+ my $relation = Lintian::Relation->new->logical_and(
+ map { $processable->relation($_) }@{$fields});
+
+ for my $redundant_set ($relation->redundancies) {
+
+ $self->hint(
+ 'redundant-build-prerequisites',
+ join(', ', sort @{$redundant_set})
+ );
+ }
+ }
+
+ # Make sure build dependencies and conflicts are consistent.
+ my $build_all = $processable->relation('Build-Depends-All');
+
+ for my $field (
+ qw{Build-Conflicts Build-Conflicts-Indep Build-Conflicts-Arch}) {
+
+ my @conflicts= $processable->fields->trimmed_list($field, qr{\s*,\s*});
+ my @contradictions = grep { $build_all->satisfies($_) } @conflicts;
+
+ my $position = $processable->fields->position($field);
+ my $pointer = $processable->debian_control->item->pointer($position);
+
+ $self->pointed_hint('build-conflicts-with-build-dependency',
+ $pointer, $field, $_)
+ for @contradictions;
+ }
+
+ my (@arch_dep_pkgs, @dbg_pkgs);
+ for my $installable ($group->get_installables) {
+
+ if ($installable->name =~ m/-dbg$/) {
+ push(@dbg_pkgs, $installable);
+
+ } elsif ($installable->fields->value('Architecture') ne 'all'){
+ push(@arch_dep_pkgs, $installable);
+ }
+ }
+
+ my $dstr = join($VERTICAL_BAR, map { quotemeta($_->name) } @arch_dep_pkgs);
+ my $depregex = qr/^(?:$dstr)$/;
+ for my $dbg_proc (@dbg_pkgs) {
+ my $deps = $processable->binary_relation($dbg_proc->name, 'strong');
+ my $missing = 1;
+ $missing = 0
+ if $deps->matches($depregex, Lintian::Relation::VISIT_PRED_NAME);
+ if ($missing && $dbg_proc->is_transitional) {
+ # If it is a transitional package, allow it to depend
+ # on another -dbg instead.
+ $missing = 0
+ if $deps->matches(qr/-dbg \Z/xsm,
+ Lintian::Relation::VISIT_PRED_NAME);
+ }
+ $self->hint('dbg-package-missing-depends', $dbg_proc->name)
+ if $missing;
+ }
+
+ # Check for a python*-dev build dependency in source packages that
+ # build only arch: all packages.
+ if ($arch_dep_packages == 0 and $build_all->satisfies($PYTHON_DEV)) {
+ $self->hint('build-depends-on-python-dev-with-no-arch-any');
+ }
+
+ my $bdepends = $processable->relation('Build-Depends');
+
+ # libmodule-build-perl
+ # matches() instead of satisfies() because of possible OR relation
+ $self->hint('libmodule-build-perl-needs-to-be-in-build-depends')
+ if $processable->relation('Build-Depends-Indep')
+ ->equals('libmodule-build-perl', Lintian::Relation::VISIT_PRED_NAME)
+ && !$bdepends->equals('libmodule-build-perl',
+ Lintian::Relation::VISIT_PRED_NAME);
+
+ # libmodule-build-tiny-perl
+ $self->hint('libmodule-build-tiny-perl-needs-to-be-in-build-depends')
+ if $processable->relation('Build-Depends-Indep')
+ ->satisfies('libmodule-build-tiny-perl')
+ && !$bdepends->satisfies('libmodule-build-tiny-perl:any');
+
+ return;
+}
+
+# splits "foo:bar (>= 1.2.3) [!i386 ia64] <stage1 !nocheck> <cross>" into
+# ( "foo", "bar", [ ">=", "1.2.3" ], [ [ "i386", "ia64" ], 1 ], [ [ "stage1", "!nocheck" ] , [ "cross" ] ], "" )
+# ^^^ ^^
+# count of negated arches, if ! was given ||
+# rest (should always be "" for valid dependencies)
+sub _split_dep {
+ my $dep = shift;
+ my ($pkg, $dmarch, $version, $darch, $restr)
+ = ($EMPTY, $EMPTY, [$EMPTY,$EMPTY], [[], 0], []);
+
+ if ($dep =~ s/^\s*([^<\s\[\(]+)\s*//) {
+ ($pkg, $dmarch) = split(/:/, $1, 2);
+ $dmarch //= $EMPTY; # Ensure it is defined (in case there is no ":")
+ }
+
+ if (length $dep) {
+ if ($dep
+ =~ s/\s* \( \s* (<<|<=|>=|>>|[=<>]) \s* ([^\s(]+) \s* \) \s*//x) {
+ @{$version} = ($1, $2);
+ }
+ if ($dep && $dep =~ s/\s*\[([^\]]+)\]\s*//) {
+ my $t = $1;
+ $darch->[0] = [split /\s+/, $t];
+ my $negated = 0;
+ for my $arch (@{ $darch->[0] }) {
+ $negated++ if $arch =~ s/^!//;
+ }
+ $darch->[1] = $negated;
+ }
+ while ($dep && $dep =~ s/\s*<([^>]+)>\s*//) {
+ my $t = $1;
+ push(@{$restr}, [split /\s+/, $t]);
+ }
+ }
+
+ return ($pkg, $dmarch, $version, $darch, $restr, $dep);
+}
+
+sub check_field {
+ my ($self, $field, $data) = @_;
+
+ my $processable = $self->processable;
+
+ my $has_default_mta
+ = $processable->relation($field)
+ ->equals('default-mta', Lintian::Relation::VISIT_PRED_NAME);
+ my $has_mail_transport_agent = $processable->relation($field)
+ ->equals('mail-transport-agent', Lintian::Relation::VISIT_PRED_NAME);
+
+ $self->hint('default-mta-dependency-not-listed-first',"$field: $data")
+ if $processable->relation($field)
+ ->matches(qr/\|\s+default-mta/, Lintian::Relation::VISIT_OR_CLAUSE_FULL);
+
+ if ($has_default_mta) {
+ $self->hint(
+ 'default-mta-dependency-does-not-specify-mail-transport-agent',
+ "$field: $data")
+ unless $has_mail_transport_agent;
+ } elsif ($has_mail_transport_agent) {
+ $self->hint(
+ 'mail-transport-agent-dependency-does-not-specify-default-mta',
+ "$field: $data")
+ unless $has_default_mta;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/PackageType.pm b/lib/Lintian/Check/Fields/PackageType.pm
new file mode 100644
index 0000000..a8defcd
--- /dev/null
+++ b/lib/Lintian/Check/Fields/PackageType.pm
@@ -0,0 +1,58 @@
+# fields/package_type -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::PackageType;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->fields->declares('Package-Type');
+
+ my $type = $self->processable->fields->value('Package-Type');
+
+ $self->hint('explicit-default-in-package-type')
+ if $type eq 'deb';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Priority.pm b/lib/Lintian/Check/Fields/Priority.pm
new file mode 100644
index 0000000..91fa6bb
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Priority.pm
@@ -0,0 +1,82 @@
+# fields/priority -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Priority;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Priority');
+
+ my $priority = $fields->unfolded_value('Priority');
+
+ if ($self->processable->type eq 'source'
+ || !$self->processable->is_auto_generated) {
+
+ $self->hint('priority-extra-is-replaced-by-priority-optional')
+ if $priority eq 'extra';
+
+ # Re-map to optional to avoid an additional warning from
+ # lintian
+ $priority = 'optional'
+ if $priority eq 'extra';
+ }
+
+ my $KNOWN_PRIOS = $self->data->load('fields/priorities');
+
+ $self->hint('unknown-priority', $priority)
+ unless $KNOWN_PRIOS->recognizes($priority);
+
+ $self->hint('excessive-priority-for-library-package', $priority)
+ if $self->processable->name =~ /^lib/
+ && $self->processable->name !~ /-bin$/
+ && $self->processable->name !~ /^libc[0-9.]+$/
+ && (any { $_ eq $self->processable->fields->value('Section') }
+ qw(libdevel libs))
+ && (any { $_ eq $priority } qw(required important standard));
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Recommended.pm b/lib/Lintian/Check/Fields/Recommended.pm
new file mode 100644
index 0000000..2c780b8
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Recommended.pm
@@ -0,0 +1,142 @@
+# fields/recommended -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Recommended;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $AT => q{@};
+
+# policy section 5.2 states unequivocally that the two fields Section
+# and Priority are recommended not only in the source paragraph, but
+# also in the binary paragraphs.
+
+# in the author's opinion, however, it does not make sense to flag them
+# there because the same two fields in the source paragraph provide the
+# default for the fields in the binary package paragraph.
+
+# moreover, such duplicate tags would then trigger the tag
+# binary-control-field-duplicates-source elsewhere, which would be
+# super confusing
+
+# policy 5.2
+my @DEBIAN_CONTROL_SOURCE = qw(Section Priority);
+my @DEBIAN_CONTROL_INSTALLABLE = qw(); # Section Priority
+
+# policy 5.3
+my @INSTALLATION_CONTROL = qw(Section Priority);
+
+# policy 5.4
+my @DSC = qw(Package-List);
+
+# policy 5.5
+my @CHANGES = qw(Urgency);
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+ my @missing_dsc = grep { !$fields->declares($_) } @DSC;
+
+ my $dscfile = path($self->processable->path)->basename;
+ $self->hint('recommended-field', $dscfile, $_) for @missing_dsc;
+
+ my $debian_control = $self->processable->debian_control;
+ my $control_item = $debian_control->item;
+
+ # look at d/control source paragraph
+ my $source_fields = $debian_control->source_fields;
+
+ my @missing_control_source
+ = grep { !$source_fields->declares($_) }@DEBIAN_CONTROL_SOURCE;
+
+ my $source_position = $source_fields->position;
+ my $source_pointer = $control_item->pointer($source_position);
+
+ $self->pointed_hint('recommended-field', $source_pointer,
+ '(in section for source)', $_)
+ for @missing_control_source;
+
+ # look at d/control installable paragraphs
+ for my $installable ($debian_control->installables) {
+
+ my $installable_fields
+ = $debian_control->installable_fields($installable);
+
+ my @missing_control_installable
+ = grep {!$installable_fields->declares($_)}
+ @DEBIAN_CONTROL_INSTALLABLE;
+
+ my $installable_position = $installable_fields->position;
+ my $installable_pointer= $control_item->pointer($installable_position);
+
+ $self->pointed_hint('recommended-field', $installable_pointer,
+ "(in section for $installable)", $_)
+ for @missing_control_installable;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ my @missing_installation_control
+ = grep { !$fields->declares($_) } @INSTALLATION_CONTROL;
+
+ my $debfile = path($self->processable->path)->basename;
+ $self->hint('recommended-field', $debfile, $_)
+ for @missing_installation_control;
+
+ return;
+}
+
+sub changes {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ my @missing_changes = grep { !$fields->declares($_) } @CHANGES;
+
+ my $changesfile = path($self->processable->path)->basename;
+ $self->hint('recommended-field', $changesfile, $_) for @missing_changes;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Required.pm b/lib/Lintian/Check/Fields/Required.pm
new file mode 100644
index 0000000..3b5213f
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Required.pm
@@ -0,0 +1,144 @@
+# fields/required -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Required;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(all);
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $AT => q{@};
+
+# policy 5.2
+my @DEBIAN_CONTROL_SOURCE = qw(Source Maintainer Standards-Version);
+my @DEBIAN_CONTROL_INSTALLABLE = qw(Package Architecture Description);
+
+# policy 5.3
+my @INSTALLATION_CONTROL
+ = qw(Package Version Architecture Maintainer Description);
+
+# policy 5.4
+my @DSC = qw(Format Source Version Maintainer Standards-Version
+ Checksums-Sha1 Checksums-Sha256 Files);
+
+# policy 5.5
+# Binary and Description were removed, see Bug#963524
+my @CHANGES = qw(Format Date Source Architecture Version Distribution
+ Maintainer Changes Checksums-Sha1 Checksums-Sha256 Files);
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+
+ # policy 5.6.11
+ if (all { $debian_control->installable_package_type($_) eq 'udeb' }
+ $debian_control->installables) {
+ @DEBIAN_CONTROL_SOURCE
+ = grep { $_ ne 'Standards-Version' } @DEBIAN_CONTROL_SOURCE;
+ @DSC = grep { $_ ne 'Standards-Version' } @DSC;
+ }
+
+ my $fields = $self->processable->fields;
+ my @missing_dsc = grep { !$fields->declares($_) } @DSC;
+
+ my $dscfile = path($self->processable->path)->basename;
+ $self->hint('required-field', $dscfile, $_) for @missing_dsc;
+
+ my $control_item = $debian_control->item;
+
+ # look at d/control source paragraph
+ my $source_fields = $debian_control->source_fields;
+
+ my @missing_control_source
+ = grep { !$source_fields->declares($_) }@DEBIAN_CONTROL_SOURCE;
+
+ my $source_position = $source_fields->position;
+ my $source_pointer = $control_item->pointer($source_position);
+
+ $self->pointed_hint('required-field', $source_pointer,
+ '(in section for source)', $_)
+ for @missing_control_source;
+
+ # look at d/control installable paragraphs
+ for my $installable ($debian_control->installables) {
+
+ my $installable_fields
+ = $debian_control->installable_fields($installable);
+
+ my @missing_control_installable
+ = grep {!$installable_fields->declares($_)}
+ @DEBIAN_CONTROL_INSTALLABLE;
+
+ my $installable_position = $installable_fields->position;
+ my $installable_pointer= $control_item->pointer($installable_position);
+
+ $self->pointed_hint('required-field', $installable_pointer,
+ "(in section for $installable)", $_)
+ for @missing_control_installable;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ my @missing_installation_control
+ = grep { !$fields->declares($_) } @INSTALLATION_CONTROL;
+
+ my $debfile = path($self->processable->path)->basename;
+ $self->hint('required-field', $debfile, $_)
+ for @missing_installation_control;
+
+ return;
+}
+
+sub changes {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ my @missing_changes = grep { !$fields->declares($_) } @CHANGES;
+
+ my $changesfile = path($self->processable->path)->basename;
+ $self->hint('required-field', $changesfile, $_) for @missing_changes;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Section.pm b/lib/Lintian/Check/Fields/Section.pm
new file mode 100644
index 0000000..f0373a9
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Section.pm
@@ -0,0 +1,140 @@
+# fields/section -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Section;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+our %KNOWN_ARCHIVE_PARTS
+ = map { $_ => 1 } qw(non-free contrib non-free-firmware);
+
+sub udeb {
+ my ($self) = @_;
+
+ my $section = $self->processable->fields->unfolded_value('Section');
+
+ $self->hint('wrong-section-for-udeb', $section)
+ unless $section eq 'debian-installer';
+
+ return;
+}
+
+sub always {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+
+ return
+ unless $self->processable->fields->declares('Section');
+
+ my $KNOWN_SECTIONS = $self->data->sections;
+
+ # Mapping of package names to section names
+ my $NAME_SECTION_MAPPINGS
+ = $self->data->load('fields/name_section_mappings',qr/\s*=>\s*/);
+
+ my $section = $self->processable->fields->unfolded_value('Section');
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ my @parts = split(m{/}, $section, 2);
+
+ my $division;
+ $division = $parts[0]
+ if @parts > 1;
+
+ my $fraction = $parts[-1];
+
+ if (defined $division) {
+ $self->hint('unknown-section', $section)
+ unless $KNOWN_ARCHIVE_PARTS{$division};
+ }
+
+ if ($fraction eq 'unknown' && !length $division) {
+ $self->hint('section-is-dh_make-template');
+ } else {
+ $self->hint('unknown-section', $section)
+ unless $KNOWN_SECTIONS->recognizes($fraction);
+ }
+
+ # Check package name <-> section. oldlibs is a special case; let
+ # anything go there.
+ if ($fraction ne 'oldlibs') {
+
+ for my $pattern ($NAME_SECTION_MAPPINGS->all()) {
+
+ my $want = $NAME_SECTION_MAPPINGS->value($pattern);
+
+ next
+ unless $pkg =~ m{$pattern}x;
+
+ unless ($fraction eq $want) {
+
+ my $better
+ = (defined $division ? "$division/" : $EMPTY) . $want;
+ $self->hint('wrong-section-according-to-package-name',
+ "$section => $better");
+ }
+
+ last;
+ }
+ }
+
+ if ($fraction eq 'debug') {
+
+ $self->hint('wrong-section-according-to-package-name', $section)
+ if $pkg !~ /-dbg(?:sym)?$/;
+ }
+
+ if ($self->processable->is_transitional) {
+
+ my $priority = $self->processable->fields->unfolded_value('Priority');
+
+ $self->hint('transitional-package-not-oldlibs-optional',
+ "$fraction/$priority")
+ unless $priority eq 'optional' && $fraction eq 'oldlibs';
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Source.pm b/lib/Lintian/Check/Fields/Source.pm
new file mode 100644
index 0000000..455bba3
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Source.pm
@@ -0,0 +1,99 @@
+# fields/source -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Source;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $UNDERSCORE => q{_};
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ # required in source packages, but dpkg-source already refuses to unpack
+ # without this field (and fields depends on unpacked)
+ return
+ unless $fields->declares('Source');
+
+ my $source = $fields->unfolded_value('Source');
+
+ my $basename = path($self->processable->path)->basename;
+ my ($stem) = split($UNDERSCORE, $basename, 2);
+
+ die encode_utf8(
+ "Source field does not match package name $source != $stem")
+ if $source ne $stem;
+
+ $self->hint('source-field-malformed', $source)
+ if $source !~ /^[a-z0-9][-+\.a-z0-9]+\z/;
+
+ return;
+}
+
+sub always {
+ my ($self) = @_;
+
+ # treated separately above
+ return
+ if $self->processable->type eq 'source';
+
+ my $fields = $self->processable->fields;
+
+ # optional in binary packages
+ return
+ unless $fields->declares('Source');
+
+ my $source = $fields->unfolded_value('Source');
+
+ $self->hint('source-field-malformed', $source)
+ unless $source =~ m{^ $PKGNAME_REGEX
+ \s*
+ # Optional Version e.g. (1.0)
+ (?:\((?:\d+:)?(?:[-\.+:a-zA-Z0-9~]+?)(?:-[\.+a-zA-Z0-9~]+)?\))?\s*$}x;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/StandardsVersion.pm b/lib/Lintian/Check/Fields/StandardsVersion.pm
new file mode 100644
index 0000000..482dd74
--- /dev/null
+++ b/lib/Lintian/Check/Fields/StandardsVersion.pm
@@ -0,0 +1,164 @@
+# fields/standards-version -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2008-2009 Russ Allbery
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::StandardsVersion;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Date::Parse qw(str2time);
+use List::SomeUtils qw(any first_value);
+use POSIX qw(strftime);
+use Sort::Versions;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $DOT => q{.};
+
+const my $MAXIMUM_COMPONENTS_ANALYZED => 3;
+
+const my $DATE_ONLY => '%Y-%m-%d';
+const my $DATE_AND_TIME => '%Y-%m-%d %H:%M:%S UTC';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->fields->declares('Standards-Version');
+
+ my $compliance_standard
+ = $self->processable->fields->value('Standards-Version');
+
+ my @compliance_components = split(/[.]/, $compliance_standard);
+ if (@compliance_components < $MAXIMUM_COMPONENTS_ANALYZED
+ || any { !/^\d+$/ } @compliance_components) {
+
+ $self->hint('invalid-standards-version', $compliance_standard);
+ return;
+ }
+
+ $self->hint('standards-version', $compliance_standard);
+
+ my ($compliance_major, $compliance_minor, $compliance_patch)
+ = @compliance_components;
+ my $compliance_normalized
+ = $compliance_major. $DOT. $compliance_minor. $DOT. $compliance_patch;
+
+ my $policy_releases = $self->data->policy_releases;
+ my $latest_standard = $policy_releases->latest_version;
+
+ my ($latest_major, $latest_minor, $latest_patch)
+ = ((split(/[.]/, $latest_standard))[0..$MAXIMUM_COMPONENTS_ANALYZED]);
+
+ # a fourth digit is a non-normative change in policy
+ my $latest_normalized
+ = $latest_major . $DOT . $latest_minor . $DOT . $latest_patch;
+
+ my $changelog_epoch;
+ my $distribution;
+
+ my ($entry) = @{$self->processable->changelog->entries};
+ if (defined $entry) {
+ $changelog_epoch = $entry->Timestamp;
+ $distribution = $entry->Distribution;
+ }
+
+ # assume recent date if there is no changelog; activates most tags
+ $changelog_epoch //= $policy_releases->epoch($latest_standard);
+ $distribution //= $EMPTY;
+
+ unless ($policy_releases->is_known($compliance_standard)) {
+
+ # could be newer
+ if (versioncmp($compliance_standard, $latest_standard) == 1) {
+
+ $self->hint('newer-standards-version',
+ "$compliance_standard (current is $latest_normalized)")
+ unless $distribution =~ /backports/;
+
+ } else {
+ $self->hint('invalid-standards-version', $compliance_standard);
+ }
+
+ return;
+ }
+
+ my $compliance_epoch = $policy_releases->epoch($compliance_standard);
+
+ my $changelog_date = strftime($DATE_ONLY, gmtime $changelog_epoch);
+ my $compliance_date = strftime($DATE_ONLY, gmtime $compliance_epoch);
+
+ my $changelog_timestamp= strftime($DATE_AND_TIME, gmtime $changelog_epoch);
+ my $compliance_timestamp
+ = strftime($DATE_AND_TIME, gmtime $compliance_epoch);
+
+ # catch packages dated prior to release of their standard
+ if ($compliance_epoch > $changelog_epoch) {
+
+ # show precision if needed
+ my $warp_illustration = "($changelog_date < $compliance_date)";
+ $warp_illustration = "($changelog_timestamp < $compliance_timestamp)"
+ if $changelog_date eq $compliance_date;
+
+ $self->hint('timewarp-standards-version', $warp_illustration)
+ unless $distribution eq 'UNRELEASED';
+ }
+
+ my @newer_versions = List::SomeUtils::before {
+ $policy_releases->epoch($_) <= $compliance_epoch
+ }
+ @{$policy_releases->ordered_versions};
+
+ # a fourth digit is a non-normative change in policy
+ my @newer_normative_versions
+ = grep { /^ \d+ [.] \d+ [.] \d+ (?:[.] 0)? $/sx } @newer_versions;
+
+ my @newer_normative_epochs
+ = map { $policy_releases->epoch($_) } @newer_normative_versions;
+
+ my @normative_epochs_then_known
+ = grep { $_ <= $changelog_epoch } @newer_normative_epochs;
+
+ my $outdated_illustration
+ = "$compliance_standard (released $compliance_date) (current is $latest_normalized)";
+
+ # use normative to prevent tag changes on minor new policy edits
+ $self->hint('out-of-date-standards-version', $outdated_illustration)
+ if @normative_epochs_then_known;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Style.pm b/lib/Lintian/Check/Fields/Style.pm
new file mode 100644
index 0000000..fe82d22
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Style.pm
@@ -0,0 +1,84 @@
+# fields/style -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Style;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# the fields in d/control provide the values for many fields elsewhere
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+ my $control_item = $debian_control->item;
+
+ # look at d/control source paragraph
+ my $source_fields = $debian_control->source_fields;
+
+ $self->check_style($source_fields, $control_item);
+
+ for my $installable ($debian_control->installables) {
+
+ # look at d/control installable paragraphs
+ my $installable_fields
+ = $debian_control->installable_fields($installable);
+
+ $self->check_style($installable_fields, $control_item);
+ }
+
+ return;
+}
+
+sub check_style {
+ my ($self, $fields, $item) = @_;
+
+ for my $name ($fields->names) {
+
+ # title-case the field name
+ my $standard = lc $name;
+ $standard =~ s/\b(\w)/\U$1/g;
+
+ # capitalize up to three letters after an X, if followed by hyphen
+ $standard =~ s/^(X[SBC]{1,3})-/\U$1-/i;
+
+ my $position = $fields->position($name);
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('cute-field', $pointer, "$name vs $standard")
+ unless $name eq $standard;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Subarchitecture.pm b/lib/Lintian/Check/Fields/Subarchitecture.pm
new file mode 100644
index 0000000..185f601
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Subarchitecture.pm
@@ -0,0 +1,55 @@
+# fields/subarchitecture -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Subarchitecture;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ #---- Subarchitecture (udeb)
+
+ # may trigger unfolding tag
+ my $subarch = $fields->unfolded_value('Subarchitecture');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/TerminalControl.pm b/lib/Lintian/Check/Fields/TerminalControl.pm
new file mode 100644
index 0000000..0d2b02b
--- /dev/null
+++ b/lib/Lintian/Check/Fields/TerminalControl.pm
@@ -0,0 +1,62 @@
+# fields/terminal-control -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::TerminalControl;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $ESCAPE => qq{\033};
+
+sub always {
+ my ($self) = @_;
+
+ my @names = $self->processable->fields->names;
+
+ # fields that contain ESC characters
+ my @escaped
+ = grep { index($self->processable->fields->value($_), $ESCAPE) >= 0 }
+ @names;
+
+ $self->hint('ansi-escape', $_, $self->processable->fields->value($_))
+ for @escaped;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Trimmed.pm b/lib/Lintian/Check/Fields/Trimmed.pm
new file mode 100644
index 0000000..24777f7
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Trimmed.pm
@@ -0,0 +1,52 @@
+# fields/trimmed -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Trimmed;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my @all = $self->processable->fields->names;
+
+ for my $name (@all) {
+
+ my $value = $self->processable->fields->value($name);
+ $self->hint('trimmed-field', $name, $value);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Unknown.pm b/lib/Lintian/Check/Fields/Unknown.pm
new file mode 100644
index 0000000..79a0ddd
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Unknown.pm
@@ -0,0 +1,86 @@
+# fields/unknown -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Unknown;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Whitelist of XS-* source fields
+my %source_field_whitelist = (
+ 'Autobuild' => 1,
+ 'Go-Import-Path' => 1,
+ 'Ruby-Versions' => 1,
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $KNOWN_SOURCE_FIELDS= $self->data->load('common/source-fields');
+ my @unknown= $self->processable->fields->extra($KNOWN_SOURCE_FIELDS->all);
+
+ # The grep filter is a workaround for #1014885 and #1029471
+ $self->hint('unknown-field', $_)
+ for grep { !exists($source_field_whitelist{$_}) } @unknown;
+
+ return;
+}
+
+sub binary {
+ my ($self) = @_;
+
+ my $KNOWN_BINARY_FIELDS= $self->data->load('fields/binary-fields');
+ my @unknown= $self->processable->fields->extra($KNOWN_BINARY_FIELDS->all);
+
+ $self->hint('unknown-field', $_)for @unknown;
+
+ return;
+}
+
+sub udeb {
+ my ($self) = @_;
+
+ my $KNOWN_UDEB_FIELDS = $self->data->load('fields/udeb-fields');
+ my @unknown = $self->processable->fields->extra($KNOWN_UDEB_FIELDS->all);
+
+ $self->hint('unknown-field', $_)for @unknown;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Uploaders.pm b/lib/Lintian/Check/Fields/Uploaders.pm
new file mode 100644
index 0000000..bfad0c4
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Uploaders.pm
@@ -0,0 +1,71 @@
+# fields/uploaders -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Uploaders;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->fields->declares('Uploaders');
+
+ my $uploaders = $self->processable->fields->value('Uploaders');
+
+ # Note, not expected to hit on uploaders anymore, as dpkg
+ # now strips newlines for the .dsc, and the newlines don't
+ # hurt in debian/control
+
+ # check for empty field see #783628
+ if ($uploaders =~ /,\s*,/) {
+ $self->hint('uploader-name-missing','you have used a double comma');
+ $uploaders =~ s/,\s*,/,/g;
+ }
+
+ if ($self->processable->fields->declares('Maintainer')) {
+
+ my $maintainer = $self->processable->fields->value('Maintainer');
+
+ $self->hint('maintainer-also-in-uploaders')
+ if $uploaders =~ m/\Q$maintainer/;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Urgency.pm b/lib/Lintian/Check/Fields/Urgency.pm
new file mode 100644
index 0000000..7e87309
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Urgency.pm
@@ -0,0 +1,60 @@
+# fields/urgency -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software. It is distributed under the terms of
+# the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any
+# later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Urgency;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub changes {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->fields->declares('Urgency');
+
+ my $urgency = $self->processable->fields->value('Urgency');
+
+ # translate to lowercase
+ my $lowercase = lc $urgency;
+
+ # discard anything after the first word
+ $lowercase =~ s/ .*//;
+
+ $self->hint('bad-urgency-in-changes-file', $urgency)
+ unless any { $lowercase =~ $_ } qw(low medium high critical emergency);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Vcs.pm b/lib/Lintian/Check/Fields/Vcs.pm
new file mode 100644
index 0000000..8bf7858
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Vcs.pm
@@ -0,0 +1,378 @@
+# fields/vcs -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Vcs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+
+const my $EMPTY => q{};
+const my $QUESTION_MARK => q{?};
+
+const my $NOT_EQUALS => q{!=};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my %VCS_EXTRACT = (
+ Browser => sub { return @_;},
+ Arch => sub { return @_;},
+ Bzr => sub { return @_;},
+ # cvs rootdir followed by optional module name:
+ Cvs => sub { return shift =~ /^(.+?)(?:\s+(\S*))?$/;},
+ Darcs => sub { return @_;},
+ # hg uri followed by optional -b branchname
+ Hg => sub { return shift =~ /^(.+?)(?:\s+-b\s+(\S*))?$/;},
+ # git uri followed by optional "[subdir]", "-b branchname" etc.
+ Git => sub {
+ return shift =~ /^(.+?)(?:(?:\s+\[(\S*)\])?(?:\s+-b\s+(\S*))?){0,2}$/;
+ },
+ Svn => sub { return @_;},
+ # New "mtn://host?branch" uri or deprecated "host branch".
+ Mtn => sub { return shift =~ /^(.+?)(?:\s+\S+)?$/;},
+);
+
+my %VCS_CANONIFY = (
+ Browser => sub {
+ $_[0] =~ s{https?://svn\.debian\.org/wsvn/}
+ {https://anonscm.debian.org/viewvc/};
+ $_[0] =~ s{https?\Q://git.debian.org/?p=\E}
+ {https://anonscm.debian.org/git/};
+ $_[0] =~ s{https?\Q://bzr.debian.org/loggerhead/\E}
+ {https://anonscm.debian.org/loggerhead/};
+ $_[0] =~ s{https?\Q://salsa.debian.org/\E([^/]+/[^/]+)\.git/?$}
+ {https://salsa.debian.org/$1};
+
+ if ($_[0] =~ m{https?\Q://anonscm.debian.org/viewvc/\E}xsm) {
+ if ($_[0] =~ s{\?(.*[;\&])?op=log(?:[;\&](.*))?\Z}{}xsm) {
+ my (@keep) = ($1, $2, $3);
+ my $final = join($EMPTY, grep {defined} @keep);
+
+ $_[0] .= $QUESTION_MARK . $final
+ if $final ne $EMPTY;
+
+ $_[1] = 'vcs-field-bitrotted';
+ }
+ }
+ },
+ Cvs => sub {
+ if (
+ $_[0] =~ s{\@(?:cvs\.alioth|anonscm)\.debian\.org:/cvsroot/}
+ {\@anonscm.debian.org:/cvs/}
+ ) {
+ $_[1] = 'vcs-field-bitrotted';
+ }
+ $_[0]=~ s{\@\Qcvs.alioth.debian.org:/cvs/}{\@anonscm.debian.org:/cvs/};
+ },
+ Arch => sub {
+ $_[0] =~ s{https?\Q://arch.debian.org/arch/\E}
+ {https://anonscm.debian.org/arch/};
+ },
+ Bzr => sub {
+ $_[0] =~ s{https?\Q://bzr.debian.org/\E}
+ {https://anonscm.debian.org/bzr/};
+ $_[0] =~ s{https?\Q://anonscm.debian.org/bzr/bzr/\E}
+ {https://anonscm.debian.org/bzr/};
+ },
+ Git => sub {
+ if (
+ $_[0] =~ s{git://(?:git|anonscm)\.debian\.org/~}
+ {https://anonscm.debian.org/git/users/}
+ ) {
+ $_[1] = 'vcs-git-uses-invalid-user-uri';
+ }
+ $_[0] =~ s{(https?://.*?\.git)(?:\.git)+$}{$1};
+ $_[0] =~ s{https?\Q://git.debian.org/\E(?:git/?)?}
+ {https://anonscm.debian.org/git/};
+ $_[0] =~ s{https?\Q://anonscm.debian.org/git/git/\E}
+ {https://anonscm.debian.org/git/};
+ $_[0] =~ s{\Qgit://git.debian.org/\E(?:git/?)?}
+ {https://anonscm.debian.org/git/};
+ $_[0] =~ s{\Qgit://anonscm.debian.org/git/\E}
+ {https://anonscm.debian.org/git/};
+ $_[0] =~ s{https?\Q://salsa.debian.org/\E([^/]+/[^/\.]+)(?!\.git)$}
+ {https://salsa.debian.org/$1.git};
+ },
+ Hg => sub {
+ $_[0] =~ s{https?\Q://hg.debian.org/\E}
+ {https://anonscm.debian.org/hg/};
+ $_[0] =~ s{https?\Q://anonscm.debian.org/hg/hg/\E}
+ {https://anonscm.debian.org/hg/};
+ },
+ Svn => sub {
+ $_[0] =~ s{\Qsvn://cvs.alioth.debian.org/\E}
+ {svn://anonscm.debian.org/};
+ $_[0] =~ s{\Qsvn://svn.debian.org/\E}
+ {svn://anonscm.debian.org/};
+ $_[0] =~ s{\Qsvn://anonscm.debian.org/svn/\E}
+ {svn://anonscm.debian.org/};
+ },
+);
+
+# Valid URI formats for the Vcs-* fields
+# currently only checks the protocol, not the actual format of the URI
+my %VCS_RECOMMENDED_URIS = (
+ Browser => qr{^https?://},
+ Arch => qr{^https?://},
+ Bzr => qr{^(?:lp:|(?:nosmart\+)?https?://)},
+ Cvs => qr{^:(?:pserver:|ext:_?anoncvs)},
+ Darcs => qr{^https?://},
+ Hg => qr{^https?://},
+ Git => qr{^(?:git|https?|rsync)://},
+ Svn => qr{^(?:svn|(?:svn\+)?https?)://},
+ Mtn => qr{^mtn://},
+);
+
+my %VCS_VALID_URIS = (
+ Arch => qr{^https?://},
+ Bzr => qr{^(?:sftp|(?:bzr\+)?ssh)://},
+ Cvs => qr{^(?:-d\s*)?:(?:ext|pserver):},
+ Hg => qr{^ssh://},
+ Git => qr{^(?:git\+)?ssh://|^[\w.]+@[a-zA-Z0-9.]+:[/a-zA-Z0-9.]},
+ Svn => qr{^(?:svn\+)?ssh://},
+ Mtn => qr{^[\w.-]+$},
+);
+
+has VCS_HOSTERS_BY_PATTERN => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %vcs_hosters_by_pattern;
+
+ my $KNOWN_VCS_HOSTERS
+ = $self->data->load('fields/vcs-hosters',qr/\s*~~\s*/);
+
+ for my $pattern ($KNOWN_VCS_HOSTERS->all) {
+
+ my @known_hosters
+ = split(m{,}, $KNOWN_VCS_HOSTERS->value($pattern));
+ $vcs_hosters_by_pattern{$pattern} = \@known_hosters;
+ }
+
+ return \%vcs_hosters_by_pattern;
+ }
+);
+
+sub always {
+ my ($self) = @_;
+
+ my $type = $self->processable->type;
+ my $processable = $self->processable;
+
+ # team-maintained = maintainer or uploaders field contains a mailing list
+ my $is_teammaintained = 0;
+ my $team_email = $EMPTY;
+ # co-maintained = maintained by an informal group of people,
+ # i. e. >= 1 uploader and not team-maintained
+ my $is_comaintained = 0;
+ my $is_maintained_by_individual = 1;
+ my $num_uploaders = 0;
+ for my $field (qw(Maintainer Uploaders)) {
+
+ next
+ unless $processable->fields->declares($field);
+
+ my $maintainer = $processable->fields->unfolded_value($field);
+
+ if ($maintainer =~ /\b(\S+\@lists(?:\.alioth)?\.debian\.org)\b/
+ || $maintainer =~ /\b(\S+\@tracker\.debian\.org)\b/) {
+ $is_teammaintained = 1;
+ $team_email = $1;
+ $is_maintained_by_individual = 0;
+ }
+
+ if ($field eq 'Uploaders') {
+
+ # check for empty field see #783628
+ $maintainer =~ s/,\s*,/,/g
+ if $maintainer =~ m/,\s*,/;
+
+ my @uploaders = map { split /\@\S+\K\s*,\s*/ }
+ split />\K\s*,\s*/, $maintainer;
+
+ $num_uploaders = scalar @uploaders;
+
+ if (@uploaders) {
+ $is_comaintained = 1
+ unless $is_teammaintained;
+ $is_maintained_by_individual = 0;
+ }
+
+ }
+ }
+
+ $self->hint('package-is-team-maintained', $team_email,
+ "(with $num_uploaders uploaders)")
+ if $is_teammaintained;
+ $self->hint('package-is-co-maintained', "(with $num_uploaders uploaders)")
+ if $is_comaintained;
+ $self->hint('package-is-maintained-by-individual')
+ if $is_maintained_by_individual;
+
+ my %seen_vcs;
+ for my $platform (keys %VCS_EXTRACT) {
+
+ my $splitter = $VCS_EXTRACT{$platform};
+
+ my $fieldname = "Vcs-$platform";
+ my $maintainer = $processable->fields->value('Maintainer');
+
+ next
+ unless $processable->fields->declares($fieldname);
+
+ my $uri = $processable->fields->unfolded_value($fieldname);
+
+ my @parts = $splitter->($uri);
+ if (not @parts or not $parts[0]) {
+ $self->hint('vcs-field-uses-unknown-uri-format', $platform, $uri);
+ } else {
+ if ( $VCS_RECOMMENDED_URIS{$platform}
+ and $parts[0] !~ $VCS_RECOMMENDED_URIS{$platform}) {
+ if ( $VCS_VALID_URIS{$platform}
+ and $parts[0] =~ $VCS_VALID_URIS{$platform}) {
+ $self->hint('vcs-field-uses-not-recommended-uri-format',
+ $platform, $uri);
+ } else {
+ $self->hint('vcs-field-uses-unknown-uri-format',
+ $platform,$uri);
+ }
+ }
+
+ $self->hint('vcs-field-has-unexpected-spaces', $platform, $uri)
+ if (any { $_ and /\s/} @parts);
+
+ $self->hint('vcs-field-uses-insecure-uri', $platform, $uri)
+ if $parts[0] =~ m{^(?:git|(?:nosmart\+)?http|svn)://}
+ || $parts[0] =~ m{^(?:lp|:pserver):};
+ }
+
+ if ($VCS_CANONIFY{$platform}) {
+
+ my $canonicalized = $parts[0];
+ my $tag = 'vcs-field-not-canonical';
+
+ foreach my $canonify ($VCS_CANONIFY{$platform}) {
+ $canonify->($canonicalized, $tag);
+ }
+
+ $self->hint($tag, $platform, $parts[0], $canonicalized)
+ unless $canonicalized eq $parts[0];
+ }
+
+ if ($platform eq 'Browser') {
+
+ $self->hint('vcs-browser-links-to-empty-view', $uri)
+ if $uri =~ /rev=0&sc=0/;
+
+ } else {
+ $self->hint('vcs', lc $platform);
+ $self->hint('vcs-uri', $platform, $uri);
+ $seen_vcs{$platform}++;
+
+ for my $pattern (keys %{$self->VCS_HOSTERS_BY_PATTERN}) {
+
+ # warn once
+ my $known_hoster
+ = @{$self->VCS_HOSTERS_BY_PATTERN->{$pattern}}[0];
+
+ $self->hint('vcs-field-mismatch',
+ "Vcs-$platform", $NOT_EQUALS, "Vcs-$known_hoster",$uri)
+ if $uri =~ m/^ $pattern /xi
+ && $platform ne $known_hoster
+ && $platform ne 'Browser';
+ }
+ }
+
+ if ($uri =~ m{//(.+)\.debian\.org/}) {
+
+ $self->hint('vcs-obsolete-in-debian-infrastructure',
+ $platform, $uri)
+ unless $1 =~ m{^(?:salsa|.*\.dgit)$};
+
+ }
+
+ # orphaned
+ if ($maintainer =~ /packages\@qa.debian.org/ && $platform ne 'Browser')
+ {
+ if ($uri =~ m{//(?:.+)\.debian\.org/}) {
+
+ $self->hint('orphaned-package-maintained-in-private-space',
+ $fieldname, $uri)
+ unless $uri =~ m{//salsa\.debian\.org/debian/}
+ || $uri =~ m{//git\.dgit\.debian\.org/};
+
+ } else {
+
+ $self->hint(
+ 'orphaned-package-not-maintained-in-debian-infrastructure',
+ $fieldname, $uri
+ );
+ }
+ }
+ }
+
+ $self->hint('vcs-fields-use-more-than-one-vcs',
+ (sort map { lc } keys %seen_vcs))
+ if keys %seen_vcs > 1;
+
+ $self->hint('co-maintained-package-with-no-vcs-fields')
+ if $type eq 'source'
+ and ($is_comaintained or $is_teammaintained)
+ and not %seen_vcs;
+
+ # Check for missing Vcs-Browser headers
+ unless ($processable->fields->declares('Vcs-Browser')) {
+
+ for my $pattern (keys %{$self->VCS_HOSTERS_BY_PATTERN}) {
+
+ # warn once
+ my $platform = @{$self->VCS_HOSTERS_BY_PATTERN->{$pattern}}[0];
+
+ my $fieldname = "Vcs-$platform";
+ my $url = $processable->fields->value($fieldname);
+
+ $self->hint('missing-vcs-browser-field', $fieldname, $url)
+ if $url =~ m/^ $pattern /xi;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Version.pm b/lib/Lintian/Check/Fields/Version.pm
new file mode 100644
index 0000000..77ee0f9
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Version.pm
@@ -0,0 +1,100 @@
+# fields/version -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Version;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Dpkg::Version;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ my $dversion = Dpkg::Version->new($version);
+ unless ($dversion->is_valid) {
+ $self->hint('bad-version-number', $version);
+ return;
+ }
+
+ my ($epoch, $upstream, $debian)
+ = ($dversion->epoch, $dversion->version, $dversion->revision);
+
+ # Dpkg::Version sets the debian revision to 0 if there is
+ # no revision. So we need to check if the raw version
+ # ends with "-0".
+ $self->hint('debian-revision-is-zero', $version)
+ if $version =~ /-0$/;
+
+ my $ubuntu;
+ if($debian =~ /^(?:[^.]+)(?:\.[^.]+)?(?:\.[^.]+)?(\..*)?$/){
+ my $extra = $1;
+ if (
+ defined $extra
+ && $debian =~ m{\A
+ (?:[^.]+ubuntu[^.]+)(?:\.\d+){1,3}(\..*)?
+ \Z}xsm
+ ) {
+ $ubuntu = 1;
+ $extra = $1;
+ }
+
+ $self->hint('debian-revision-not-well-formed', $version)
+ if defined $extra;
+
+ } else {
+ $self->hint('debian-revision-not-well-formed', $version);
+ }
+
+ if ($self->processable->type eq 'source') {
+
+ $self->hint('binary-nmu-debian-revision-in-source', $version)
+ if ($debian =~ /^[^.-]+\.[^.-]+\./ && !$ubuntu)
+ || $version =~ /\+b\d+$/;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Version/Derivative.pm b/lib/Lintian/Check/Fields/Version/Derivative.pm
new file mode 100644
index 0000000..9385fa4
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Version/Derivative.pm
@@ -0,0 +1,82 @@
+# fields/version/derivative -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Version::Derivative;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Dpkg::Version;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ my $dversion = Dpkg::Version->new($version);
+ return
+ unless $dversion->is_valid;
+
+ my ($epoch, $upstream, $debian)
+ = ($dversion->epoch, $dversion->version, $dversion->revision);
+
+ my $DERIVATIVE_VERSIONS
+ = $self->data->load('fields/derivative-versions',qr/\s*~~\s*/);
+
+ unless ($self->processable->native) {
+
+ for my $pattern ($DERIVATIVE_VERSIONS->all) {
+
+ next
+ if $version =~ m/$pattern/;
+
+ my $explanation = $DERIVATIVE_VERSIONS->value($pattern);
+
+ $self->hint('invalid-version-number-for-derivative',
+ $version,"($explanation)");
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Version/Repack/Count.pm b/lib/Lintian/Check/Fields/Version/Repack/Count.pm
new file mode 100644
index 0000000..c793385
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Version/Repack/Count.pm
@@ -0,0 +1,65 @@
+# fields/version/repack/count -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2021 Kentaro Hayashi
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Version::Repack::Count;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ # repack counts in native packages are dealt with elsewhere
+ return
+ if $self->processable->native;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ $self->hint('anticipated-repack-count', $version)
+ if $version =~ m{ dfsg [01] - }x;
+
+ $self->hint('dot-before-repack-count', $version)
+ if $version =~ / dfsg [.] \d+ /x;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Version/Repack/Native.pm b/lib/Lintian/Check/Fields/Version/Repack/Native.pm
new file mode 100644
index 0000000..6ca1602
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Version/Repack/Native.pm
@@ -0,0 +1,63 @@
+# fields/version/repack/native -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Version::Repack::Native;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ # Checks for the dfsg convention for repackaged upstream
+ # source. Only check these against the source package to not
+ # repeat ourselves too much.
+ $self->hint('dfsg-version-in-native-package', $version)
+ if $version =~ /dfsg/
+ && $self->processable->native;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Version/Repack/Period.pm b/lib/Lintian/Check/Fields/Version/Repack/Period.pm
new file mode 100644
index 0000000..12e8928
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Version/Repack/Period.pm
@@ -0,0 +1,60 @@
+# fields/version/repack/period -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Version::Repack::Period;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ $self->hint('dfsg-version-with-period', $version)
+ if $version =~ m{ [.] dfsg }x
+ && !$self->processable->native;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Version/Repack/Tilde.pm b/lib/Lintian/Check/Fields/Version/Repack/Tilde.pm
new file mode 100644
index 0000000..206b288
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Version/Repack/Tilde.pm
@@ -0,0 +1,60 @@
+# fields/version/repack/tilde -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Kentaro Hayashi
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Version::Repack::Tilde;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ $self->hint('dfsg-version-with-tilde', $version)
+ if $version =~ /~dfsg/
+ && !$self->processable->native;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fields/Version/Repack/Typo.pm b/lib/Lintian/Check/Fields/Version/Repack/Typo.pm
new file mode 100644
index 0000000..c466df2
--- /dev/null
+++ b/lib/Lintian/Check/Fields/Version/Repack/Typo.pm
@@ -0,0 +1,64 @@
+# fields/version/repack/typo -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fields::Version::Repack::Typo;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Dpkg::Version qw(version_check);
+
+use Lintian::Relation::Version qw(versions_compare);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ $self->hint('dfsg-version-misspelled', $version)
+ if $version =~ /dsfg/
+ && !$self->processable->native;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Architecture.pm b/lib/Lintian/Check/Files/Architecture.pm
new file mode 100644
index 0000000..70cab47
--- /dev/null
+++ b/lib/Lintian/Check/Files/Architecture.pm
@@ -0,0 +1,105 @@
+# files/architecture -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Architecture;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has TRIPLETS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch;
+ my %triplets = map { $DEB_HOST_MULTIARCH->{$_} => $_ }
+ keys %{$DEB_HOST_MULTIARCH};
+
+ return \%triplets;
+ }
+);
+
+has depends_on_architecture => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # for directories
+ if ($item->name =~ m{^(?:usr/)?lib/([^/]+)/$}) {
+
+ my $potential_triplet = $1;
+
+ if (exists $self->TRIPLETS->{$potential_triplet}) {
+
+ my $from_triplet = $self->TRIPLETS->{$potential_triplet};
+ my $port = $self->processable->fields->value('Architecture');
+
+ $self->pointed_hint('triplet-dir-and-architecture-mismatch',
+ $item->pointer, "is for $from_triplet instead of $port")
+ unless $from_triplet eq $port;
+ }
+ }
+
+ # for files
+ if ($item->dirname =~ m{^(?:usr)?/lib/([^/]+)/$}) {
+
+ my $potential_triplet = $1;
+
+ $self->depends_on_architecture(1)
+ if exists $self->TRIPLETS->{$potential_triplet};
+ }
+
+ $self->depends_on_architecture(1)
+ if $item->is_file
+ && $item->size > 0
+ && $item->file_type !~ m/^very short file/
+ && $item->file_type !~ m/\bASCII text\b/
+ && $item->name !~ m{^usr/share/};
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint('package-contains-no-arch-dependent-files')
+ if !$self->depends_on_architecture
+ && $self->processable->fields->value('Architecture') ne 'all'
+ && $self->processable->type ne 'udeb'
+ && !$self->processable->is_transitional
+ && !$self->processable->is_meta_package;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Artifact.pm b/lib/Lintian/Check/Files/Artifact.pm
new file mode 100644
index 0000000..5344cfc
--- /dev/null
+++ b/lib/Lintian/Check/Files/Artifact.pm
@@ -0,0 +1,140 @@
+# files/artifact -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Artifact;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(first_value);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Directory checks. These regexes match a directory that shouldn't be in the
+# source package and associate it with a tag (minus the leading
+# source-contains or debian-adds). Note that only one of these regexes
+# should trigger for any single directory.
+my @directory_checks = (
+ [qr{^(.+/)?CVS/?$} => 'cvs-control-dir'],
+ [qr{^(.+/)?\.svn/?$} => 'svn-control-dir'],
+ [qr{^(.+/)?\.bzr/?$} => 'bzr-control-dir'],
+ [qr{^(.+/)?\{arch\}/?$} => 'arch-control-dir'],
+ [qr{^(.+/)?\.arch-ids/?$} => 'arch-control-dir'],
+ [qr{^(.+/)?,,.+/?$} => 'arch-control-dir'],
+ [qr{^(.+/)?\.git/?$} => 'git-control-dir'],
+ [qr{^(.+/)?\.hg/?$} => 'hg-control-dir'],
+ [qr{^(.+/)?\.be/?$} => 'bts-control-dir'],
+ [qr{^(.+/)?\.ditrack/?$} => 'bts-control-dir'],
+
+ # Special case (can only be triggered for diffs)
+ [qr{^(.+/)?\.pc/?$} => 'quilt-control-dir'],
+);
+
+# File checks. These regexes match files that shouldn't be in the source
+# package and associate them with a tag (minus the leading source-contains or
+# debian-adds). Note that only one of these regexes should trigger for any
+# given file.
+my @file_checks = (
+ [qr{^(.+/)?svn-commit\.(.+\.)?tmp$} => 'svn-commit-file'],
+ [qr{^(.+/)?svk-commit.+\.tmp$} => 'svk-commit-file'],
+ [qr{^(.+/)?\.arch-inventory$} => 'arch-inventory-file'],
+ [qr{^(.+/)?\.hgtags$} => 'hg-tags-file'],
+ [qr{^(.+/)?\.\#(.+?)\.\d+(\.\d+)*$} => 'cvs-conflict-copy'],
+ [qr{^(.+/)?(.+?)\.(r[1-9]\d*)$} => 'svn-conflict-file'],
+ [qr{\.(orig|rej)$} => 'patch-failure-file'],
+ [qr{((^|/)[^/]+\.swp|~)$} => 'editor-backup-file'],
+);
+
+sub source {
+ my ($self) = @_;
+
+ my @added_by_debian;
+ my $prefix;
+ if ($self->processable->native) {
+
+ @added_by_debian = @{$self->processable->patched->sorted_list};
+ $prefix = 'source-contains';
+
+ } else {
+ my $patched = $self->processable->patched;
+ my $orig = $self->processable->orig;
+
+ @added_by_debian
+ = grep { !defined $orig->lookup($_->name) } @{$patched->sorted_list};
+
+ # remove root quilt control folder and all paths in it
+ # created when 3.0 (quilt) source packages are unpacked
+ @added_by_debian = grep { $_->name !~ m{^.pc/} } @added_by_debian
+ if $self->processable->source_format eq '3.0 (quilt)';
+
+ my @common_items
+ = grep { defined $orig->lookup($_->name) } @{$patched->sorted_list};
+ my @touched_by_debian
+ = grep { $_->md5sum ne $orig->lookup($_->name)->md5sum }
+ @common_items;
+
+ $self->hint('no-debian-changes')
+ unless @added_by_debian || @touched_by_debian;
+
+ $prefix = 'debian-adds';
+ }
+
+ # ignore lintian test set; should use automatic loop in the future
+ @added_by_debian = grep { $_->name !~ m{^t/} } @added_by_debian
+ if $self->processable->source_name eq 'lintian';
+
+ my @directories = grep { $_->is_dir } @added_by_debian;
+ for my $directory (@directories) {
+
+ my $rule = first_value { $directory->name =~ /$_->[0]/s }
+ @directory_checks;
+ $self->pointed_hint("${prefix}-$rule->[1]", $directory->pointer)
+ if defined $rule;
+ }
+
+ my @files = grep { $_->is_file } @added_by_debian;
+ for my $item (@files) {
+
+ my $rule = first_value { $item->name =~ /$_->[0]/s } @file_checks;
+ $self->pointed_hint("${prefix}-$rule->[1]", $item->pointer)
+ if defined $rule;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Banned.pm b/lib/Lintian/Check/Files/Banned.pm
new file mode 100644
index 0000000..81b5ae7
--- /dev/null
+++ b/lib/Lintian/Check/Files/Banned.pm
@@ -0,0 +1,113 @@
+# files/banned -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Banned;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $MD5SUM_DATA_FIELDS => 5;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub _md5sum_based_lintian_data {
+ my ($self, $filename) = @_;
+
+ my $data = $self->data->load($filename,qr/\s*\~\~\s*/);
+
+ my %md5sum_data;
+
+ for my $md5sum ($data->all) {
+
+ my $value = $data->value($md5sum);
+
+ my ($sha1, $sha256, $name, $reason, $link)
+ = split(/ \s* ~~ \s* /msx, $value, $MD5SUM_DATA_FIELDS);
+
+ die encode_utf8("Syntax error in $filename $.")
+ if any { !defined } ($sha1, $sha256, $name, $reason, $link);
+
+ $md5sum_data{$md5sum} = {
+ 'sha1' => $sha1,
+ 'sha256' => $sha256,
+ 'name' => $name,
+ 'reason' => $reason,
+ 'link' => $link,
+ };
+ }
+
+ return \%md5sum_data;
+}
+
+has NON_DISTRIBUTABLE_FILES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->_md5sum_based_lintian_data(
+ 'cruft/non-distributable-files');
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ my $banned = $self->NON_DISTRIBUTABLE_FILES->{$item->md5sum};
+ if (defined $banned) {
+ my $usualname = $banned->{'name'};
+ my $reason = $banned->{'reason'};
+ my $link = $banned->{'link'};
+
+ $self->pointed_hint(
+ 'license-problem-md5sum-non-distributable-file',
+ $item->pointer, "usual name is $usualname.",
+ $reason, "See also $link."
+ );
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Banned/CompiledHelp.pm b/lib/Lintian/Check/Files/Banned/CompiledHelp.pm
new file mode 100644
index 0000000..efb5eee
--- /dev/null
+++ b/lib/Lintian/Check/Files/Banned/CompiledHelp.pm
@@ -0,0 +1,58 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Banned::CompiledHelp;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # .chm files are usually generated by non-free software
+ $self->pointed_hint('source-contains-prebuilt-ms-help-file',$item->pointer)
+ if $item->basename =~ /\.chm$/i
+ && $item->file_type eq 'MS Windows HtmlHelp Data'
+ && $item->bytes !~ / Halibut, /msx;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Banned/Lenna.pm b/lib/Lintian/Check/Files/Banned/Lenna.pm
new file mode 100644
index 0000000..3bfcb2c
--- /dev/null
+++ b/lib/Lintian/Check/Files/Banned/Lenna.pm
@@ -0,0 +1,109 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Banned::Lenna;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# known bad files
+has LENNA_BLACKLIST => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %blacklist;
+
+ my $data = $self->data->load('files/banned/lenna/blacklist',
+ qr/ \s* ~~ \s* /x);
+
+ for my $md5sum ($data->all) {
+
+ my $value = $data->value($md5sum);
+
+ my ($sha1, $sha256, $name, $link)
+ = split(/ \s* ~~ \s* /msx, $value);
+
+ $blacklist{$md5sum} = {
+ 'sha1' => $sha1,
+ 'sha256' => $sha256,
+ 'name' => $name,
+ 'link' => $link,
+ };
+ }
+
+ return \%blacklist;
+ }
+);
+
+# known good files
+has LENNA_WHITELIST => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('files/banned/lenna/whitelist');
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /\bimage\b/i
+ || $item->file_type =~ /^Matlab v\d+ mat/i
+ || $item->file_type =~ /\bbitmap\b/i
+ || $item->file_type =~ /^PDF Document\b/i
+ || $item->file_type =~ /^Postscript Document\b/i;
+
+ return
+ if $self->LENNA_WHITELIST->recognizes($item->md5sum);
+
+ # Lena Soderberg image
+ $self->pointed_hint('license-problem-non-free-img-lenna', $item->pointer)
+ if $item->basename =~ / ( \b | _ ) lenn?a ( \b | _ ) /ix
+ || exists $self->LENNA_BLACKLIST->{$item->md5sum};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Bugs.pm b/lib/Lintian/Check/Files/Bugs.pm
new file mode 100644
index 0000000..69432de
--- /dev/null
+++ b/lib/Lintian/Check/Files/Bugs.pm
@@ -0,0 +1,50 @@
+# files/bugs -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Bugs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_dir;
+
+ $self->pointed_hint('package-contains-bts-control-dir', $item->pointer)
+ if $item->name =~ m{/\.(?:be|ditrack)/?$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/BuildPath.pm b/lib/Lintian/Check/Files/BuildPath.pm
new file mode 100644
index 0000000..e6c73af
--- /dev/null
+++ b/lib/Lintian/Check/Files/BuildPath.pm
@@ -0,0 +1,55 @@
+# files/build-path -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::BuildPath;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $BUILD_PATH_REGEX
+ = $self->data->load('files/build-path-regex', qr/~~~~~/);
+
+ for my $pattern ($BUILD_PATH_REGEX->all) {
+
+ $self->pointed_hint('dir-or-file-in-build-tree', $item->pointer)
+ if $item->name =~ m{$pattern}xms
+ && $self->processable->source_name ne 'sbuild'
+ && $self->processable->source_name ne 'pbuilder';
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed.pm b/lib/Lintian/Check/Files/Compressed.pm
new file mode 100644
index 0000000..d64807f
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed.pm
@@ -0,0 +1,80 @@
+# files/compressed -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $VERTICAL_BAR => q{|};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# an OR (|) regex of all compressed extension
+has COMPRESS_FILE_EXTENSIONS_OR_ALL => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $COMPRESS_FILE_EXTENSIONS
+ = $self->data->load('files/compressed-file-extensions',qr/\s+/);
+
+ my $text = join($VERTICAL_BAR,
+ map { quotemeta }$COMPRESS_FILE_EXTENSIONS->all);
+
+ return qr/$text/;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ my $regex = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL;
+
+ # see tag duplicated-compressed-file
+ my $DUPLICATED_COMPRESSED_FILE_REGEX= qr/^(.+)\.$regex$/;
+
+ # both compressed and uncompressed present
+ if ($item->name =~ $DUPLICATED_COMPRESSED_FILE_REGEX) {
+
+ $self->pointed_hint('compressed-duplicate', $item->pointer)
+ if $self->processable->installed->lookup($1);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed/Bz2.pm b/lib/Lintian/Check/Files/Compressed/Bz2.pm
new file mode 100644
index 0000000..25c8bc1
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed/Bz2.pm
@@ -0,0 +1,57 @@
+# files/compressed/bz2 -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed::Bz2;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ if ($item->name =~ /\.bz2$/si) {
+
+ safe_qx('bzip2', '--test', $item->unpacked_path);
+
+ $self->pointed_hint('broken-bz2', $item->pointer)
+ if $?;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed/Gz.pm b/lib/Lintian/Check/Files/Compressed/Gz.pm
new file mode 100644
index 0000000..6290247
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed/Gz.pm
@@ -0,0 +1,113 @@
+# files/compressed/gz -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed::Gz;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Time::Piece;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# get timestamp of first member; https://tools.ietf.org/html/rfc1952.html#page-5
+const my $GZIP_HEADER_SIZE => 8;
+
+has changelog_timestamp => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # remains 0 if there is no timestamp
+ my $changelog = $self->processable->changelog;
+ if (defined $changelog) {
+
+ my ($entry) = @{$changelog->entries};
+ return $entry->Timestamp
+ if $entry && $entry->Timestamp;
+ }
+
+ return 0;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ if ($item->name =~ /\.gz$/si) {
+
+ safe_qx('gzip', '--test', $item->unpacked_path);
+
+ $self->pointed_hint('broken-gz', $item->pointer)
+ if $?;
+ }
+
+ # gzip files
+ if ($item->file_type =~ /gzip compressed/) {
+
+ my $bytes = $item->magic($GZIP_HEADER_SIZE);
+ my (undef, $gziptime) = unpack('VV', $bytes);
+
+ if (defined $gziptime && $gziptime != 0) {
+
+ # see https://bugs.debian.org/762105
+ my $time_from_build = $gziptime - $self->changelog_timestamp;
+ if ($time_from_build > 0) {
+
+ my $architecture
+ = $self->processable->fields->value('Architecture');
+ my $multiarch
+ = $self->processable->fields->value('Multi-Arch') || 'no';
+
+ if ($multiarch eq 'same' && $item->name !~ /\Q$architecture\E/)
+ {
+ $self->pointed_hint(
+ 'gzip-file-is-not-multi-arch-same-safe',
+ $item->pointer);
+
+ } else {
+ $self->pointed_hint('package-contains-timestamped-gzip',
+ $item->pointer,gmtime($gziptime)->datetime);
+ }
+ }
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed/Lz.pm b/lib/Lintian/Check/Files/Compressed/Lz.pm
new file mode 100644
index 0000000..defed97
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed/Lz.pm
@@ -0,0 +1,77 @@
+# files/compressed/lz -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Chris Lamb
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed::Lz;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(first_value);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Util qw(locate_executable);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has lzip_command => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $command = first_value { locate_executable($_) } qw(lzip clzip);
+
+ return $command;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ my $command = $self->lzip_command;
+ return
+ unless length $command;
+
+ if ($item->name =~ /\.lz$/si) {
+
+ safe_qx($command, '--test', $item->unpacked_path);
+
+ $self->pointed_hint('broken-lz', $item->pointer)
+ if $?;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed/Lzma.pm b/lib/Lintian/Check/Files/Compressed/Lzma.pm
new file mode 100644
index 0000000..2f49853
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed/Lzma.pm
@@ -0,0 +1,57 @@
+# files/compressed/lzma -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed::Lzma;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ if ($item->name =~ /\.lzma$/si) {
+
+ safe_qx('lzma', '--test', $item->unpacked_path);
+
+ $self->pointed_hint('broken-lzma', $item->pointer)
+ if $?;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed/Lzo.pm b/lib/Lintian/Check/Files/Compressed/Lzo.pm
new file mode 100644
index 0000000..5e6cdca
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed/Lzo.pm
@@ -0,0 +1,57 @@
+# files/compressed/lzo -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed::Lzo;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ if ($item->name =~ /\.lzo$/si) {
+
+ safe_qx('lzop', '--test', $item->unpacked_path);
+
+ $self->pointed_hint('broken-lzo', $item->pointer)
+ if $?;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed/Xz.pm b/lib/Lintian/Check/Files/Compressed/Xz.pm
new file mode 100644
index 0000000..6f3c6a0
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed/Xz.pm
@@ -0,0 +1,57 @@
+# files/compressed/xz -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed::Xz;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ if ($item->name =~ /\.xz$/si) {
+
+ safe_qx('xz', '--test', $item->unpacked_path);
+
+ $self->pointed_hint('broken-xz', $item->pointer)
+ if $?;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Compressed/Zip.pm b/lib/Lintian/Check/Files/Compressed/Zip.pm
new file mode 100644
index 0000000..68b9395
--- /dev/null
+++ b/lib/Lintian/Check/Files/Compressed/Zip.pm
@@ -0,0 +1,62 @@
+# files/compressed/zip -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Compressed::Zip;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ if ($item->name =~ /\.zip$/si) {
+
+ # maybe rewrite with Archive::Zip
+
+ # may prompt for password with -t; piping yes '' does not work
+ safe_qx('unzip', '-l', $item->unpacked_path);
+
+ $self->pointed_hint('broken-zip', $item->pointer)
+ if $?;
+
+ # should issue a tag for encrypted members, see Bug#935292
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/ConfigScripts.pm b/lib/Lintian/Check/Files/ConfigScripts.pm
new file mode 100644
index 0000000..b5df56c
--- /dev/null
+++ b/lib/Lintian/Check/Files/ConfigScripts.pm
@@ -0,0 +1,108 @@
+# files/config-scripts -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::ConfigScripts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::SlidingWindow;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+ my $multiarch = $self->processable->fields->value('Multi-Arch') || 'no';
+
+ # check old style config scripts
+ if ( $item->name =~ m{^usr/bin/}
+ && $item->name =~ m/-config$/
+ && $item->is_script
+ && $item->is_regular_file) {
+
+ # try to find some indication of
+ # config file (read only one block)
+
+ open(my $fd, '<:raw', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $sfd = Lintian::SlidingWindow->new;
+ $sfd->handle($fd);
+
+ my $block = $sfd->readwindow;
+
+ # some common stuff found in config file
+ if (
+ $block
+ && ( $block =~ / flag /msx
+ || $block =~ m{ /include/ }msx
+ || $block =~ / pkg-config /msx)
+ ) {
+
+ $self->pointed_hint('old-style-config-script', $item->pointer);
+
+ # could be ok but only if multi-arch: no
+ if ($multiarch ne 'no' || $architecture eq 'all') {
+
+ # check multi-arch path
+ my $DEB_HOST_MULTIARCH
+ = $self->data->architectures->deb_host_multiarch;
+ for my $madir (values %{$DEB_HOST_MULTIARCH}) {
+
+ next
+ unless $block =~ m{\W\Q$madir\E(\W|$)}xms;
+
+ # allow files to begin with triplet if it matches arch
+ next
+ if $item->basename =~ m{^\Q$madir\E}xms;
+
+ my $tag_name = 'old-style-config-script-multiarch-path';
+ $tag_name .= '-arch-all'
+ if $architecture eq 'all';
+
+ $self->pointed_hint($tag_name, $item->pointer,
+ 'full text contains architecture specific dir',$madir);
+
+ last;
+ }
+ }
+ }
+
+ close $fd;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Contents.pm b/lib/Lintian/Check/Files/Contents.pm
new file mode 100644
index 0000000..472c419
--- /dev/null
+++ b/lib/Lintian/Check/Files/Contents.pm
@@ -0,0 +1,150 @@
+# files/contents -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Contents;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+const my $ARROW => q{ -> };
+
+my $SENSIBLE_REGEX
+ = qr{(?<!-)(?:select-editor|sensible-(?:browser|editor|pager))\b};
+
+# with this Moo default, maintainer scripts are also checked
+has switched_locations => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @files
+ = grep { $_->is_file } @{$self->processable->installed->sorted_list};
+
+ my @commands = grep { $_->name =~ m{^(?:usr/)?s?bin/} } @files;
+
+ my %switched_locations;
+ for my $command (@commands) {
+
+ my @variants = map { $_ . $SLASH . $command->basename }
+ qw(bin sbin usr/bin usr/sbin);
+ my @confused = grep { $_ ne $command->name } @variants;
+
+ $switched_locations{$_} = $command->name for @confused;
+ }
+
+ return \%switched_locations;
+ }
+);
+
+sub build_path {
+ my ($self) = @_;
+
+ my $buildinfo = $self->group->buildinfo;
+
+ return $EMPTY
+ unless $buildinfo;
+
+ return $buildinfo->fields->value('Build-Path');
+}
+
+sub check_item {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ unless ($self->processable->relation('all')->satisfies('sensible-utils')
+ || $self->processable->source_name eq 'sensible-utils') {
+
+ my $sensible = $item->mentions_in_operation($SENSIBLE_REGEX);
+ $self->pointed_hint('missing-depends-on-sensible-utils',
+ $item->pointer, $sensible)
+ if length $sensible;
+ }
+
+ unless ($self->processable->fields->value('Section') eq 'debian-installer'
+ || any { $_ eq $self->processable->source_name } qw(base-files dpkg)) {
+
+ $self->pointed_hint('uses-dpkg-database-directly', $item->pointer)
+ if length $item->mentions_in_operation(qr{/var/lib/dpkg});
+ }
+
+ # if we have a /usr/sbin/foo, check for references to /usr/bin/foo
+ my %switched_locations = %{$self->switched_locations};
+ for my $confused (keys %switched_locations) {
+
+ # may not work as expected on ELF due to ld's SHF_MERGE
+ # but word boundaries are also superior in strings spanning multiple commands
+ my $correct = $switched_locations{$confused};
+ $self->pointed_hint('bin-sbin-mismatch', $item->pointer,
+ $confused . $ARROW . $correct)
+ if length $item->mentions_in_operation(qr{ \B / \Q$confused\E \b }x);
+ }
+
+ if (length $self->build_path) {
+ my $escaped_path = quotemeta($self->build_path);
+ $self->pointed_hint('file-references-package-build-path',
+ $item->pointer)
+ if $item->bytes_match(qr{$escaped_path});
+ }
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->check_item($item);
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ $self->check_item($item);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Contents/LineLength.pm b/lib/Lintian/Check/Files/Contents/LineLength.pm
new file mode 100644
index 0000000..63f38ca
--- /dev/null
+++ b/lib/Lintian/Check/Files/Contents/LineLength.pm
@@ -0,0 +1,140 @@
+# files/contents/line-length -- lintian check script -*- perl -*-
+
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Contents::LineLength;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::UtilsBy qw(max_by);
+use Unicode::UTF8 qw(encode_utf8 decode_utf8 valid_utf8);
+
+const my $GREATER_THAN => q{>};
+const my $VERTICAL_BAR => q{|};
+
+const my $VERY_LONG => 512;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# an OR (|) regex of all compressed extension
+has BINARY_FILE_EXTENSIONS_OR_ALL => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $BINARY_FILE_EXTENSIONS
+ = $self->data->load('files/binary-file-extensions',qr/\s+/);
+ my $COMPRESSED_FILE_EXTENSIONS
+ = $self->data->load('files/compressed-file-extensions',qr/\s+/);
+
+ my $text = join(
+ $VERTICAL_BAR,
+ (
+ map { quotemeta } $BINARY_FILE_EXTENSIONS->all,
+ $COMPRESSED_FILE_EXTENSIONS->all
+ )
+ );
+
+ return qr/$text/i;
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ # Skip if no regular file
+ return
+ unless $item->is_regular_file;
+
+ # Skip if file has a known binary, XML or JSON suffix.
+ my $pattern = $self->BINARY_FILE_EXTENSIONS_OR_ALL;
+ return
+ if $item->basename
+ =~ qr{ [.] ($pattern | xml | sgml | svg | jsonl?) \s* $}x;
+
+ # Skip if we can't open it.
+ return
+ unless $item->is_open_ok;
+
+ # Skip if file is a REUSE license (LICENSES/**.txt), which are
+ # canonically provided with long lines rather than being hard-wrapped.
+ return
+ if $item->name =~ m{^ LICENSES/ .* [.] txt $}x;
+
+ # Skip if file is detected to be an image or JSON.
+ return
+ if $item->file_type =~ m{image|bitmap|JSON};
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my %line_lengths;
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+ # Skip SQL insert and select statements
+ next if ($line =~ /^(INSERT|SELECT)\s/i
+ and $item->basename =~ /sql/i);
+
+ # count codepoints, if possible
+ $line = decode_utf8($line)
+ if valid_utf8($line);
+
+ $line_lengths{$position} = length $line;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ my $longest = max_by { $line_lengths{$_} } keys %line_lengths;
+
+ return
+ unless defined $longest;
+
+ my $pointer = $item->pointer($longest);
+
+ $self->pointed_hint('very-long-line-length-in-source-file',
+ $pointer, $line_lengths{$longest}, $GREATER_THAN, $VERY_LONG)
+ if $line_lengths{$longest} > $VERY_LONG;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Date.pm b/lib/Lintian/Check/Files/Date.pm
new file mode 100644
index 0000000..3b1f479
--- /dev/null
+++ b/lib/Lintian/Check/Files/Date.pm
@@ -0,0 +1,66 @@
+# files/date -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Date;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# value from dak CVS: Dinstall::PastCutOffYear
+const my $DINSTALL_CUTOFF_YEAR => 1975;
+
+has ALLOWED_ANCIENT_FILES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('files/allowed-ancient-files');
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my ($year) = ($item->date =~ /^(\d{4})/);
+
+ $self->pointed_hint('package-contains-ancient-file',
+ $item->pointer, $item->date)
+ if $year <= $DINSTALL_CUTOFF_YEAR
+ && !$self->ALLOWED_ANCIENT_FILES->matches_any($item->name);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Debug.pm b/lib/Lintian/Check/Files/Debug.pm
new file mode 100644
index 0000000..9eead27
--- /dev/null
+++ b/lib/Lintian/Check/Files/Debug.pm
@@ -0,0 +1,55 @@
+# files/debug -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Debug;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has warned_already => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->name =~ m{^usr/lib/debug/\S}) {
+
+ $self->pointed_hint('debug-suffix-not-dbg', $item->pointer)
+ if !$self->processable->is_debug_package
+ && !$self->warned_already;
+
+ $self->warned_already(1);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/DebugPackages.pm b/lib/Lintian/Check/Files/DebugPackages.pm
new file mode 100644
index 0000000..7f83816
--- /dev/null
+++ b/lib/Lintian/Check/Files/DebugPackages.pm
@@ -0,0 +1,50 @@
+# files/debug-packages -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::DebugPackages;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('non-debug-file-in-debug-package', $item->pointer)
+ if $item->is_file
+ && $item->name !~ /\.debug$/
+ && $self->processable->is_debug_package
+ && $self->processable->is_auto_generated;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Desktop.pm b/lib/Lintian/Check/Files/Desktop.pm
new file mode 100644
index 0000000..fca3006
--- /dev/null
+++ b/lib/Lintian/Check/Files/Desktop.pm
@@ -0,0 +1,57 @@
+# files/desktop -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Desktop;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # .desktop files
+ # People have placed them everywhere, but nowadays the
+ # consensus seems to be to stick to the fd.org standard
+ # drafts, which says that .desktop files intended for
+ # menus should be placed in $XDG_DATA_DIRS/applications.
+ # The default for $XDG_DATA_DIRS is
+ # /usr/local/share/:/usr/share/, according to the
+ # basedir-spec on fd.org. As distributor, we should only
+ # allow /usr/share.
+
+ $self->pointed_hint('desktop-file-in-wrong-dir', $item->pointer)
+ if $item->name =~ m{^usr/share/gnome/apps/.*\.desktop$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Duplicates.pm b/lib/Lintian/Check/Files/Duplicates.pm
new file mode 100644
index 0000000..b1dc809
--- /dev/null
+++ b/lib/Lintian/Check/Files/Duplicates.pm
@@ -0,0 +1,88 @@
+# files/duplicates -- lintian check script -*- perl -*-
+
+# Copyright (C) 2011 Niels Thykier
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Duplicates;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has md5map => (is => 'rw', default => sub{ {} });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_regular_file;
+
+ # Ignore empty files; in some cases (e.g. python) a file is
+ # required even if it is empty and we are never looking at a
+ # substantial gain in such a case. Also see #632789
+ return
+ unless $item->size;
+
+ my $calculated = $item->md5sum;
+ return
+ unless defined $calculated;
+
+ return
+ unless $item->name =~ m{\A usr/share/doc/}xsm;
+
+ $self->md5map->{$calculated} //= [];
+
+ push(@{$self->md5map->{$calculated}}, $item);
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ for my $md5 (keys %{$self->md5map}){
+ my @files = @{ $self->md5map->{$md5} };
+
+ next
+ if scalar @files < 2;
+
+ if (any { m/changelog/i} @files) {
+ $self->hint('duplicate-changelog-files', (sort @files));
+
+ } else {
+ $self->hint('duplicate-files', (sort @files));
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/EmptyDirectories.pm b/lib/Lintian/Check/Files/EmptyDirectories.pm
new file mode 100644
index 0000000..52079cb
--- /dev/null
+++ b/lib/Lintian/Check/Files/EmptyDirectories.pm
@@ -0,0 +1,67 @@
+# files/empty-directories -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::EmptyDirectories;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_dir;
+
+ # skip base-files, which is a very special case.
+ return
+ if $self->processable->name eq 'base-files';
+
+ # ignore /var, which may hold dynamic data packages create, and /etc,
+ # which may hold configuration files generated by maintainer scripts
+ return
+ if $item->name =~ m{^var/} || $item->name =~ m{^etc/};
+
+ # Empty Perl directories are an ExtUtils::MakeMaker artifact that
+ # will be fixed in Perl 5.10, and people can cause more problems
+ # by trying to fix it, so just ignore them.
+ return
+ if $item->name =~ m{^usr/lib/(?:[^/]+/)?perl5/$}
+ || $item->name eq 'usr/share/perl5/';
+
+ # warn about empty directories
+ $self->pointed_hint('package-contains-empty-directory', $item->pointer)
+ if scalar $item->children == 0;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/EmptyPackage.pm b/lib/Lintian/Check/Files/EmptyPackage.pm
new file mode 100644
index 0000000..5b23846
--- /dev/null
+++ b/lib/Lintian/Check/Files/EmptyPackage.pm
@@ -0,0 +1,159 @@
+# files/empty-package -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::EmptyPackage;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Common files stored in /usr/share/doc/$pkg that aren't sufficient to
+# consider the package non-empty.
+has STANDARD_FILES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('files/standard-files');
+ }
+);
+
+has is_empty => (is => 'rw', default => 1);
+has is_dummy => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # check if package is empty
+ return 1
+ if $self->processable->is_transitional
+ || $self->processable->is_meta_package;
+
+ return 0;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $self->is_empty;
+
+ return
+ if $self->is_dummy;
+
+ # ignore directories
+ return
+ if $item->is_dir;
+
+ my $pkg = $self->processable->name;
+ my $ppkg = quotemeta($self->processable->name);
+
+ # skip if file is outside /usr/share/doc/$pkg directory
+ if ($item->name !~ m{^usr/share/doc/\Q$pkg\E}) {
+
+ # - except if it is a lintian override.
+ return
+ if $item->name =~ m{\A
+ # Except for:
+ usr/share/ (?:
+ # lintian overrides
+ lintian/overrides/$ppkg(?:\.gz)?
+ # reportbug scripts/utilities
+ | bug/$ppkg(?:/(?:control|presubj|script))?
+ )\Z}xsm;
+
+ $self->is_empty(0);
+
+ return;
+ }
+
+ # skip if /usr/share/doc/$pkg has files in a subdirectory
+ if ($item->name =~ m{^usr/share/doc/\Q$pkg\E/[^/]+/}) {
+
+ $self->is_empty(0);
+
+ return;
+ }
+
+ # skip /usr/share/doc/$pkg symlinks.
+ return
+ if $item->name eq "usr/share/doc/$pkg";
+
+ # For files directly in /usr/share/doc/$pkg, if the
+ # file isn't one of the uninteresting ones, the
+ # package isn't empty.
+ return
+ if $self->STANDARD_FILES->recognizes($item->basename);
+
+ # ignore all READMEs
+ return
+ if $item->basename =~ m/^README(?:\..*)?$/i;
+
+ my $pkg_arch = $self->processable->architecture;
+ unless ($pkg_arch eq 'all') {
+
+ # binNMU changelog (debhelper)
+ return
+ if $item->basename eq "changelog.Debian.${pkg_arch}.gz";
+ }
+
+ # buildinfo file (dh-buildinfo)
+ return
+ if $item->basename eq "buildinfo_${pkg_arch}.gz";
+
+ $self->is_empty(0);
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ if $self->is_dummy;
+
+ if ($self->is_empty) {
+
+ $self->hint('empty-binary-package')
+ if $self->processable->type eq 'binary';
+
+ $self->hint('empty-udeb-package')
+ if $self->processable->type eq 'udeb';
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Encoding.pm b/lib/Lintian/Check/Files/Encoding.pm
new file mode 100644
index 0000000..f175401
--- /dev/null
+++ b/lib/Lintian/Check/Files/Encoding.pm
@@ -0,0 +1,125 @@
+# files/encoding -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Encoding;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
+use Unicode::UTF8 qw(valid_utf8 encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^debian/};
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /text$/;
+
+ if ($item->name =~ m{^debian/patches/}) {
+
+ my $bytes = $item->bytes;
+ return
+ unless length $bytes;
+
+ my ($header)= split(/^---/m, $bytes, 2);
+
+ $self->pointed_hint('national-encoding', $item->pointer,'DEP-3 header')
+ unless valid_utf8($header);
+
+ } else {
+ $self->pointed_hint('national-encoding', $item->pointer)
+ unless $item->is_valid_utf8;
+ }
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /text$/ || $item->is_script;
+
+ $self->pointed_hint('national-encoding', $item->pointer)
+ unless $item->is_valid_utf8;
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # this checks debs; most other nat'l encoding tags are for source
+ # Bug#796170 also suggests limiting paths and including gzip files
+
+ # return
+ # unless $item->name =~ m{^(?:usr/)?s?bin/}
+ # || $item->name =~ m{^usr/games/}
+ # || $item->name =~ m{\.(?:p[myl]|php|rb|tcl|sh|txt)(?:\.gz)?$}
+ # || $item->name =~ m{^usr/share/doc};
+
+ if ($item->file_type =~ /text$/) {
+
+ $self->pointed_hint('national-encoding', $item->pointer)
+ unless $item->is_valid_utf8;
+ }
+
+ # for man pages also look at compressed files
+ if ( $item->name =~ m{^usr/share/man/}
+ && $item->file_type =~ /gzip compressed/) {
+
+ my $bytes;
+
+ my $path = $item->unpacked_path;
+ gunzip($path => \$bytes)
+ or die encode_utf8("gunzip $path failed: $GunzipError");
+
+ $self->pointed_hint('national-encoding', $item->pointer)
+ unless valid_utf8($bytes);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Generated.pm b/lib/Lintian/Check/Files/Generated.pm
new file mode 100644
index 0000000..35c88d5
--- /dev/null
+++ b/lib/Lintian/Check/Files/Generated.pm
@@ -0,0 +1,83 @@
+# files/generated -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Generated;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+const my $DOUBLE_QUOTE => q{"};
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ # check all patched source files except the Debian patches
+ return
+ if $item->name =~ m{^ debian/patches/ }x;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ if ($line
+ =~m{ ( This [ ] file [ ] (?: is | was ) [ ] autogenerated ) }xi
+ || $line
+ =~ m{ ( DO [ ] NOT [ ] EDIT [ ] (?: THIS [ ] FILE [ ] )? BY [ ] HAND ) }xi
+ ) {
+
+ my $marker = $1;
+
+ $self->pointed_hint(
+ 'generated-file',
+ $item->pointer($position),
+ $DOUBLE_QUOTE . $marker . $DOUBLE_QUOTE
+ );
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/HardLinks.pm b/lib/Lintian/Check/Files/HardLinks.pm
new file mode 100644
index 0000000..f115897
--- /dev/null
+++ b/lib/Lintian/Check/Files/HardLinks.pm
@@ -0,0 +1,57 @@
+# files/hard-links -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::HardLinks;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_hardlink;
+
+ my $target_dir = $item->link;
+ $target_dir =~ s{[^/]*$}{};
+
+ # link always sorts after target; hard links are calibrated
+ $self->pointed_hint('package-contains-hardlink', $item->pointer,
+ 'pointing to:', $item->link)
+ if $item->name =~ m{^etc/}
+ || $item->link =~ m{^etc/}
+ || $item->name !~ m{^\Q$target_dir\E[^/]*$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Hierarchy/Links.pm b/lib/Lintian/Check/Files/Hierarchy/Links.pm
new file mode 100644
index 0000000..2402b5d
--- /dev/null
+++ b/lib/Lintian/Check/Files/Hierarchy/Links.pm
@@ -0,0 +1,83 @@
+# files/symbolic-links/broken -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Hierarchy::Links;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::SomeUtils qw(any first_value);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+const my $ARROW => q{ -> };
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # symbolic links only
+ return
+ unless $item->is_symlink;
+
+ my $target = $item->link_normalized;
+ return
+ unless defined $target;
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+
+ my $origin_dirname= first_value { $item->dirname eq $_ } @ldconfig_folders;
+
+ # look only at links originating in common ld.so load paths
+ return
+ unless length $origin_dirname;
+
+ my $target_dirname
+ = first_value { (dirname($target) . $SLASH) eq $_ } @ldconfig_folders;
+ $target_dirname //= $EMPTY;
+
+ # no subfolders
+ $self->pointed_hint('ldconfig-escape', $item->pointer, $target)
+ unless length $target_dirname;
+
+ my @multiarch= values %{$self->data->architectures->deb_host_multiarch};
+
+ $self->pointed_hint('architecture-escape', $item->pointer, $target)
+ if (any { basename($origin_dirname) eq $_ } @multiarch)
+ && (any { $target_dirname eq "$_/" } qw{lib usr/lib usr/local/lib});
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm b/lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm
new file mode 100644
index 0000000..ebd0d1c
--- /dev/null
+++ b/lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm
@@ -0,0 +1,48 @@
+# files/hierarchy/merged-usr -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Hierarchy::MergedUsr;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('unmerged-usr', $item->pointer)
+ if $item->is_file
+ && $item->name =~ m{^(?:lib|bin|sbin)};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Hierarchy/PathSegments.pm b/lib/Lintian/Check/Files/Hierarchy/PathSegments.pm
new file mode 100644
index 0000000..b9e5535
--- /dev/null
+++ b/lib/Lintian/Check/Files/Hierarchy/PathSegments.pm
@@ -0,0 +1,57 @@
+# files/hierarchy/path-segments -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Hierarchy::PathSegments;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_dir;
+
+ my @segments = split(m{/}, $item->name);
+ return
+ unless @segments;
+
+ my $final = $segments[-1];
+ my $count = scalar grep { $final eq $_ } @segments;
+
+ $self->pointed_hint('repeated-path-segment', $item->pointer, $final)
+ if $count > 1;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Hierarchy/Standard.pm b/lib/Lintian/Check/Files/Hierarchy/Standard.pm
new file mode 100644
index 0000000..e00955b
--- /dev/null
+++ b/lib/Lintian/Check/Files/Hierarchy/Standard.pm
@@ -0,0 +1,262 @@
+# files/hierarchy/standard -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Hierarchy::Standard;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub _is_tmp_path {
+ my ($path) = @_;
+
+ return 1
+ if $path =~ m{^tmp/.}
+ || $path =~ m{^(?:var|usr)/tmp/.}
+ || $path =~ m{^/dev/shm/};
+
+ return 0;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->name =~ m{^etc/opt/.}) {
+
+ # /etc/opt
+ $self->pointed_hint('dir-or-file-in-etc-opt', $item->pointer);
+
+ } elsif ($item->name =~ m{^usr/local/\S+}) {
+ # /usr/local
+ if ($item->is_dir) {
+ $self->pointed_hint('dir-in-usr-local', $item->pointer);
+ } else {
+ $self->pointed_hint('file-in-usr-local', $item->pointer);
+ }
+
+ } elsif ($item->name =~ m{^usr/share/[^/]+$}) {
+ # /usr/share
+ $self->pointed_hint('file-directly-in-usr-share', $item->pointer)
+ if $item->is_file;
+
+ } elsif ($item->name =~ m{^usr/bin/}) {
+ # /usr/bin
+ $self->pointed_hint('subdir-in-usr-bin', $item->pointer)
+ if $item->is_dir
+ && $item->name =~ m{^usr/bin/.}
+ && $item->name !~ m{^usr/bin/(?:X11|mh)/};
+
+ } elsif ($self->processable->type ne 'udeb'
+ && $item->name =~ m{^usr/[^/]+/$}) {
+
+ # /usr subdirs
+ if ($item->name=~ m{^usr/(?:dict|doc|etc|info|man|adm|preserve)/}) {
+ # FSSTND dirs
+ $self->pointed_hint('FSSTND-dir-in-usr', $item->pointer);
+ } elsif (
+ $item->name !~ m{^usr/(?:X11R6|X386|
+ bin|games|include|
+ lib|
+ local|sbin|share|
+ src|spool|tmp)/}x
+ ) {
+ # FHS dirs
+ if ($item->name =~ m{^usr/lib(?<libsuffix>64|x?32)/}) {
+ my $libsuffix = $+{libsuffix};
+ # eglibc exception is due to FHS. Other are
+ # transitional, waiting for full
+ # implementation of multi-arch. Note that we
+ # allow (e.g.) "lib64" packages to still use
+ # these dirs, since their use appears to be by
+ # intention.
+ unless ($self->processable->source_name =~ m/^e?glibc$/
+ or $self->processable->name =~ m/^lib$libsuffix/) {
+
+ $self->pointed_hint('non-multi-arch-lib-dir',
+ $item->pointer);
+ }
+ } else {
+ # see Bug#834607
+ $self->pointed_hint('non-standard-dir-in-usr', $item->pointer)
+ unless $item->name =~ m{^usr/libexec/};
+ }
+
+ }
+
+ # unless $item =~ m,^usr/[^/]+-linuxlibc1/,; was tied
+ # into print above...
+ # Make an exception for the altdev dirs, which will go
+ # away at some point and are not worth moving.
+ }
+
+ # /var subdirs
+ elsif ($self->processable->type ne 'udeb'
+ && $item->name =~ m{^var/[^/]+/$}) {
+
+ if ($item->name =~ m{^var/(?:adm|catman|named|nis|preserve)/}) {
+ # FSSTND dirs
+ $self->pointed_hint('FSSTND-dir-in-var', $item->pointer);
+
+ } elsif ($self->processable->name eq 'base-files'
+ && $item->name =~ m{^var/(?:backups|local)/}) {
+ # base-files is special
+ # ignore
+
+ } elsif (
+ $item->name !~ m{\A var/
+ (?: account|lib|cache|crash|games
+ |lock|log|opt|run|spool|state
+ |tmp|www|yp)/
+ }xsm
+ ) {
+ # FHS dirs with exception in Debian policy
+ $self->pointed_hint('non-standard-dir-in-var', $item->pointer);
+ }
+
+ } elsif ($self->processable->type ne 'udeb'
+ && $item->name =~ m{^var/lib/games/.}) {
+ $self->pointed_hint('non-standard-dir-in-var', $item->pointer);
+
+ } elsif ($self->processable->type ne 'udeb'
+ && $item->name =~ m{^var/lock/.}) {
+ # /var/lock
+ $self->pointed_hint('dir-or-file-in-var-lock', $item->pointer);
+
+ } elsif ($self->processable->type ne 'udeb'
+ && $item->name =~ m{^var/run/.}) {
+ # /var/run
+ $self->pointed_hint('dir-or-file-in-var-run', $item->pointer);
+
+ } elsif ($self->processable->type ne 'udeb' && $item->name =~ m{^run/.}) {
+ $self->pointed_hint('dir-or-file-in-run', $item->pointer);
+
+ } elsif ($item->name =~ m{^var/www/\S+}) {
+ # /var/www
+ # Packages are allowed to create /var/www since it's
+ # historically been the default document root, but they
+ # shouldn't be installing stuff under that directory.
+ $self->pointed_hint('dir-or-file-in-var-www', $item->pointer);
+
+ } elsif ($item->name =~ m{^opt/.}) {
+ # /opt
+ $self->pointed_hint('dir-or-file-in-opt', $item->pointer);
+
+ } elsif ($item->name =~ m{^hurd/}) {
+ return;
+
+ } elsif ($item->name =~ m{^servers/}) {
+ return;
+
+ } elsif ($item->name =~ m{^home/.}) {
+ # /home
+ $self->pointed_hint('dir-or-file-in-home', $item->pointer);
+
+ } elsif ($item->name =~ m{^root/.}) {
+ $self->pointed_hint('dir-or-file-in-home', $item->pointer);
+
+ } elsif (_is_tmp_path($item->name)) {
+ # /tmp, /var/tmp, /usr/tmp
+ $self->pointed_hint('dir-or-file-in-tmp', $item->pointer);
+
+ } elsif ($item->name =~ m{^mnt/.}) {
+ # /mnt
+ $self->pointed_hint('dir-or-file-in-mnt', $item->pointer);
+
+ } elsif ($item->name =~ m{^bin/}) {
+ # /bin
+ $self->pointed_hint('subdir-in-bin', $item->pointer)
+ if $item->is_dir && $item->name =~ m{^bin/.};
+
+ } elsif ($item->name =~ m{^srv/.}) {
+ # /srv
+ $self->pointed_hint('dir-or-file-in-srv', $item->pointer);
+
+ }elsif (
+ $item->name =~ m{^[^/]+/$}
+ && $item->name !~ m{\A (?:
+ bin|boot|dev|etc|home|lib
+ |mnt|opt|root|run|sbin|srv|sys
+ |tmp|usr|var) /
+ }xsm
+ ) {
+ # FHS directory?
+
+ # Make an exception for the base-files package here and
+ # other similar packages because they install a slew of
+ # top-level directories for setting up the base system.
+ # (Specifically, /cdrom, /floppy, /initrd, and /proc are
+ # not mentioned in the FHS).
+ if ($item->name =~ m{^lib(?<libsuffix>64|x?32)/}) {
+ my $libsuffix = $+{libsuffix};
+
+ # see comments for ^usr/lib(?'libsuffix'64|x?32)
+ $self->pointed_hint('non-multi-arch-lib-dir', $item->pointer)
+ unless $self->processable->source_name =~ m/^e?glibc$/
+ || $self->processable->name =~ m/^lib$libsuffix/;
+
+ } else {
+ $self->pointed_hint('non-standard-toplevel-dir', $item->pointer)
+ unless $self->processable->name eq 'base-files'
+ || $self->processable->name eq 'hurd'
+ || $self->processable->name eq 'hurd-udeb'
+ || $self->processable->name =~ /^rootskel(?:-bootfloppy)?/;
+ }
+ }
+
+ # compatibility symlinks should not be used
+ $self->pointed_hint('use-of-compat-symlink', $item->pointer)
+ if $item->name =~ m{^usr/(?:spool|tmp)/}
+ || $item->name =~ m{^usr/(?:doc|bin)/X11/}
+ || $item->name =~ m{^var/adm/};
+
+ # any files
+ $self->pointed_hint('file-in-unusual-dir', $item->pointer)
+ unless $item->is_dir
+ || $self->processable->type eq 'udeb'
+ || $item->name =~ m{^usr/(?:bin|dict|doc|games|
+ include|info|lib(?:x?32|64)?|
+ man|sbin|share|src|X11R6)/}x
+ || $item->name =~ m{^lib(?:x?32|64)?/(?:modules/|libc5-compat/)?}
+ || $item->name =~ m{^var/(?:games|lib|www|named)/}
+ || $item->name =~ m{^(?:bin|boot|dev|etc|sbin)/}
+ # non-FHS, but still usual
+ || $item->name =~ m{^usr/[^/]+-linux[^/]*/}
+ || $item->name =~ m{^usr/libexec/} # FHS 3.0 / #834607
+ || $item->name =~ m{^usr/iraf/}
+ # not allowed, but tested individually
+ || $item->name =~ m{\A (?:
+ build|home|mnt|opt|root|run|srv
+ |(?:(?:usr|var)/)?tmp)|var/www/}xsm;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/IeeeData.pm b/lib/Lintian/Check/Files/IeeeData.pm
new file mode 100644
index 0000000..0c2ba68
--- /dev/null
+++ b/lib/Lintian/Check/Files/IeeeData.pm
@@ -0,0 +1,79 @@
+# files/ieee-data -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::IeeeData;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $VERTICAL_BAR => q{|};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# an OR (|) regex of all compressed extension
+has COMPRESS_FILE_EXTENSIONS_OR_ALL => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $COMPRESS_FILE_EXTENSIONS
+ = $self->data->load('files/compressed-file-extensions',qr/\s+/);
+
+ my $text = join($VERTICAL_BAR,
+ map { quotemeta }$COMPRESS_FILE_EXTENSIONS->all);
+
+ return qr/$text/;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $regex = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL;
+
+ if ( $item->is_regular_file
+ && $item->name
+ =~ m{/(?:[^/]-)?(?:oui|iab)(?:\.(txt|idx|db))?(?:\.$regex)?\Z}x) {
+
+ # see #785662
+ if ($item->name =~ / oui /msx || $item->name =~ / iab /msx) {
+
+ $self->pointed_hint('package-installs-ieee-data', $item->pointer)
+ unless $self->processable->source_name eq 'ieee-data';
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Includes.pm b/lib/Lintian/Check/Files/Includes.pm
new file mode 100644
index 0000000..ec10bb8
--- /dev/null
+++ b/lib/Lintian/Check/Files/Includes.pm
@@ -0,0 +1,69 @@
+# files/includes -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Includes;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw{any};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# case insensitive regular expressions for overly generic paths
+const my @GENERIC_PATHS => ('^ util[s]? [.]h $');
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ my $consumed = $item->name;
+ return
+ unless $consumed =~ s{^usr/include/}{};
+
+ my @multiarch_folders
+ = values %{$self->data->architectures->deb_host_multiarch};
+
+ for my $tuple (@multiarch_folders) {
+
+ last
+ if $consumed =~ s{^$tuple/}{};
+ }
+
+ $self->pointed_hint('header-has-overly-generic-name', $item->pointer)
+ if any { $consumed =~ m{ $_ }isx } @GENERIC_PATHS;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Init.pm b/lib/Lintian/Check/Files/Init.pm
new file mode 100644
index 0000000..25ff77d
--- /dev/null
+++ b/lib/Lintian/Check/Files/Init.pm
@@ -0,0 +1,79 @@
+# files/init -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Init;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(none);
+
+const my $NOT_EQUAL => q{!=};
+
+const my $EXECUTABLE_PERMISSIONS => oct(755);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # /etc/init
+ $self->pointed_hint('package-installs-deprecated-upstart-configuration',
+ $item->pointer)
+ if $item->name =~ m{^etc/init/\S};
+
+ # /etc/init.d
+ $self->pointed_hint(
+ 'non-standard-file-permissions-for-etc-init.d-script',
+ $item->pointer,
+ $item->octal_permissions,
+ $NOT_EQUAL,
+ sprintf('%04o', $EXECUTABLE_PERMISSIONS)
+ )
+ if $item->name =~ m{^etc/init\.d/\S}
+ && $item->name !~ m{^etc/init\.d/(?:README|skeleton)$}
+ && $item->operm != $EXECUTABLE_PERMISSIONS
+ && $item->is_file;
+
+ # /etc/rc.d && /etc/rc?.d
+ $self->pointed_hint('package-installs-into-etc-rc.d', $item->pointer)
+ if $item->name =~ m{^etc/rc(?:\d|S)?\.d/\S}
+ && (none { $self->processable->name eq $_ } qw(sysvinit file-rc))
+ && $self->processable->type ne 'udeb';
+
+ # /etc/rc.boot
+ $self->pointed_hint('package-installs-into-etc-rc.boot', $item->pointer)
+ if $item->name =~ m{^etc/rc\.boot/\S};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/LdSo.pm b/lib/Lintian/Check/Files/LdSo.pm
new file mode 100644
index 0000000..2f0b9c1
--- /dev/null
+++ b/lib/Lintian/Check/Files/LdSo.pm
@@ -0,0 +1,48 @@
+# files/ld-so -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::LdSo;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('package-modifies-ld.so-search-path', $item->pointer)
+ if $item->name =~ m{^etc/ld\.so\.conf\.d/.+$}
+ && $self->processable->name !~ /^libc/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Licenses.pm b/lib/Lintian/Check/Files/Licenses.pm
new file mode 100644
index 0000000..5ca61e4
--- /dev/null
+++ b/lib/Lintian/Check/Files/Licenses.pm
@@ -0,0 +1,112 @@
+# files/licenses -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Licenses;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # license files
+ if (
+ $item->basename =~ m{ \A
+ # Look for commonly used names for license files
+ (?: copying | licen[cs]e | l?gpl | bsd | artistic )
+ # ... possibly followed by a version
+ [v0-9._-]*
+ (?:\. .* )? \Z
+ }xsmi
+ # Ignore some common extensions for source or compiled
+ # extension files. There was at least one file named
+ # "license.el". These are probably license-displaying
+ # code, not license files. Also ignore executable files
+ # in general. This means we get false-negatives for
+ # licenses files marked executable, but these will trigger
+ # a warning about being executable. (See #608866)
+ #
+ # Another exception is made for .html and .php because
+ # preserving working links is more important than saving
+ # some bytes, and because a package had an HTML form for
+ # licenses called like that. Another exception is made
+ # for various picture formats since those are likely to
+ # just be simply pictures.
+ #
+ # DTD files are excluded at the request of the Mozilla
+ # suite maintainers. Zope products include license files
+ # for runtime display. underXXXlicense.docbook files are
+ # from KDE.
+ #
+ # Ignore extra license files in examples, since various
+ # package building software includes example packages with
+ # licenses.
+ && !$item->is_executable
+ && $item->name !~ m{ \. (?:
+ # Common "non-license" file extensions...
+ el|[ch]|cc|p[ylmc]|[hu]i|p_hi|html|php|rb|xpm
+ |png|jpe?g|gif|svg|dtd|mk|lisp|yml|rs|ogg|xbm
+ ) \Z}xsm
+ && $item->name !~ m{^usr/share/zope/Products/.*\.(?:dtml|pt|cpt)$}
+ && $item->name !~ m{/under\S+License\.docbook$}
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/}
+ # liblicense has a manpage called license
+ && $item->name !~ m{^usr/share/man/(?:[^/]+/)?man\d/}
+ # liblicense (again)
+ && $item->name !~ m{^usr/share/pyshared-data/}
+ # Rust crate unmodified upstream sources
+ && $item->name !~ m{^usr/share/cargo/registry/}
+ # Some GNOME/GTK software uses these to show the "license
+ # header".
+ && $item->name !~ m{
+ ^usr/share/(?:gnome/)?help/[^/]+/[^/]+/license\.page$
+ }x
+ # base-files (which is required to ship them)
+ && $item->name !~ m{^usr/share/common-licenses/[^/]+$}
+ && !length($item->link)
+ # Sphinx includes various license files
+ && $item->name !~ m{/_sources/license(?:\.rst)?\.txt$}i
+ ) {
+
+ # okay, we cannot rule it out based on file name; but if
+ # it is an elf or a static library, we also skip it. (In
+ # case you hadn't guessed; liblicense)
+
+ $self->pointed_hint('extra-license-file', $item->pointer)
+ unless $item->file_type =~ m/^[^,]*\bELF\b/
+ || $item->file_type =~ m/\bcurrent ar archive\b/;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Locales.pm b/lib/Lintian/Check/Files/Locales.pm
new file mode 100644
index 0000000..e645a83
--- /dev/null
+++ b/lib/Lintian/Check/Files/Locales.pm
@@ -0,0 +1,204 @@
+# files/locales -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2013 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2019 Adam D. Barratt <adam@adam-barratt.org.uk>
+# Copyright (C) 2021 Felix Lechner
+#
+# Based in part on a shell script that was:
+# Copyright (C) 2010 Raphael Geissert <atomo64@gmail.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Locales;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use JSON::MaybeXS;
+use List::SomeUtils qw(first_value);
+use Path::Tiny;
+
+const my $EMPTY => q{};
+
+const my $ARROW => q{->};
+
+const my $RESERVED => $EMPTY;
+const my $SPECIAL => q{S};
+
+const my %CONFUSING_LANGUAGES => (
+ # Albanian is sq, not al:
+ 'al' => 'sq',
+ # Chinese is zh, not cn:
+ 'cn' => 'zh',
+ # Czech is cs, not cz:
+ 'cz' => 'cs',
+ # Danish is da, not dk:
+ 'dk' => 'da',
+ # Greek is el, not gr:
+ 'gr' => 'el',
+ # Indonesian is id, not in:
+ 'in' => 'id',
+);
+
+const my %CONFUSING_COUNTRIES => (
+ # UK != GB
+ 'en_UK' => 'en_GB',
+);
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has ISO639_3_by_alpha3 => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ local $ENV{LC_ALL} = 'C';
+
+ my $bytes = path('/usr/share/iso-codes/json/iso_639-3.json')->slurp;
+ my $json = decode_json($bytes);
+
+ my %iso639_3;
+ for my $entry (@{$json->{'639-3'}}) {
+
+ my $alpha_3 = $entry->{alpha_3};
+
+ $iso639_3{$alpha_3} = $entry;
+ }
+
+ return \%iso639_3;
+ }
+);
+
+has LOCALE_CODES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ local $ENV{LC_ALL} = 'C';
+
+ my %CODES;
+ for my $entry (values %{$self->ISO639_3_by_alpha3}) {
+
+ my $type = $entry->{type};
+
+ # https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=692548#10
+ next
+ if $type eq $RESERVED || $type eq $SPECIAL;
+
+ # also have two letters, ISO 639-1
+ my $two_letters;
+ $two_letters = $entry->{alpha_2}
+ if exists $entry->{alpha_2};
+
+ $CODES{$two_letters} = $EMPTY
+ if length $two_letters;
+
+ # three letters, ISO 639-2
+ my $three_letters = $entry->{alpha_3};
+
+ # a value indicates that two letters are preferred
+ $CODES{$three_letters} = $two_letters || $EMPTY;
+ }
+
+ return \%CODES;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_dir;
+
+ return
+ unless $item->name =~ m{^ usr/share/locale/ ([^/]+) / $}x;
+
+ my $folder = $1;
+
+ # without encoding
+ my ($with_country) = split(m/[.@]/, $folder);
+
+ # special exception
+ return
+ if $with_country eq 'l10n';
+
+ # without country code
+ my ($two_or_three, $country) = split(m/_/, $with_country);
+
+ $country //= $EMPTY;
+
+ return
+ unless length $two_or_three;
+
+ # check some common language errors
+ if (exists $CONFUSING_LANGUAGES{$two_or_three}) {
+
+ my $fixed = $folder;
+ $fixed =~ s{^ $two_or_three }{$CONFUSING_LANGUAGES{$two_or_three}}x;
+
+ $self->pointed_hint('incorrect-locale-code', $item->pointer, $folder,
+ $ARROW,$fixed);
+ return;
+ }
+
+ # check some common country errors
+ if (exists $CONFUSING_COUNTRIES{$with_country}) {
+
+ my $fixed = $folder;
+ $fixed =~ s{^ $with_country }{$CONFUSING_COUNTRIES{$with_country}}x;
+
+ $self->pointed_hint('incorrect-locale-code', $item->pointer, $folder,
+ $ARROW,$fixed);
+ return;
+ }
+
+ # check known codes
+ if (exists $self->LOCALE_CODES->{$two_or_three}) {
+
+ my $replacement = $self->LOCALE_CODES->{$two_or_three};
+ return
+ unless length $replacement;
+
+ # a value indicates that two letters are preferred
+ my $fixed = $folder;
+ $fixed =~ s{^ $two_or_three }{$replacement}x;
+
+ $self->pointed_hint('incorrect-locale-code', $item->pointer, $folder,
+ $ARROW,$fixed);
+
+ return;
+ }
+
+ $self->pointed_hint('unknown-locale-code', $item->pointer, $folder);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Missing.pm b/lib/Lintian/Check/Files/Missing.pm
new file mode 100644
index 0000000..4c6eda5
--- /dev/null
+++ b/lib/Lintian/Check/Files/Missing.pm
@@ -0,0 +1,50 @@
+# files/missing -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Missing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ( $item->is_dir
+ && $item->faux) {
+
+ $self->pointed_hint('missing-intermediate-directory', $item->pointer);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/MultiArch.pm b/lib/Lintian/Check/Files/MultiArch.pm
new file mode 100644
index 0000000..5d6a2f0
--- /dev/null
+++ b/lib/Lintian/Check/Files/MultiArch.pm
@@ -0,0 +1,111 @@
+# files/multi-arch -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::MultiArch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has TRIPLETS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch;
+ my %triplets = map { $DEB_HOST_MULTIARCH->{$_} => $_ }
+ keys %{$DEB_HOST_MULTIARCH};
+
+ return \%triplets;
+ }
+);
+
+my %PATH_DIRECTORIES = map { $_ => 1 } qw(
+ bin/ sbin/ usr/bin/ usr/sbin/ usr/games/ );
+
+has has_public_executable => (is => 'rw', default => 0);
+has has_public_shared_library => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+ my $multiarch = $self->processable->fields->value('Multi-Arch') || 'no';
+
+ my $DEB_HOST_MULTIARCH= $self->data->architectures->deb_host_multiarch;
+ my $multiarch_dir = $DEB_HOST_MULTIARCH->{$architecture};
+
+ if ( !$item->is_dir
+ && defined $multiarch_dir
+ && $multiarch eq 'foreign'
+ && $item->name =~ m{^usr/lib/\Q$multiarch_dir\E/(.*)$}) {
+
+ my $tail = $1;
+
+ $self->pointed_hint('multiarch-foreign-cmake-file', $item->pointer)
+ if $tail =~ m{^cmake/.+\.cmake$};
+
+ $self->pointed_hint('multiarch-foreign-pkgconfig', $item->pointer)
+ if $tail =~ m{^pkgconfig/[^/]+\.pc$};
+
+ $self->pointed_hint('multiarch-foreign-static-library', $item->pointer)
+ if $tail =~ m{^lib[^/]+\.a$};
+ }
+
+ if (exists($PATH_DIRECTORIES{$item->dirname})) {
+ $self->has_public_executable(1);
+ }
+
+ if ($item->name =~ m{^(?:usr/)?lib/(?:([^/]+)/)?lib[^/]*\.so$}) {
+ $self->has_public_shared_library(1)
+ if (!defined($1) || exists $self->TRIPLETS->{$1});
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+ my $multiarch = $self->processable->fields->value('Multi-Arch') || 'no';
+
+ $self->hint('multiarch-foreign-shared-library')
+ if $architecture ne 'all'
+ and $multiarch eq 'foreign'
+ and $self->has_public_shared_library
+ and not $self->has_public_executable;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Names.pm b/lib/Lintian/Check/Files/Names.pm
new file mode 100644
index 0000000..a6b022c
--- /dev/null
+++ b/lib/Lintian/Check/Files/Names.pm
@@ -0,0 +1,163 @@
+# files/names -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Names;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::Compare;
+use Unicode::UTF8 qw(valid_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my %PATH_DIRECTORIES = map { $_ => 1 } qw(
+ bin/ sbin/ usr/bin/ usr/sbin/ usr/games/ );
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # unusual characters
+ $self->pointed_hint('file-name-ends-in-whitespace', $item->pointer)
+ if $item->name =~ /\s+\z/;
+
+ $self->pointed_hint('star-file', $item->pointer)
+ if $item->name =~ m{/\*\z};
+
+ $self->pointed_hint('hyphen-file', $item->pointer)
+ if $item->name =~ m{/-\z};
+
+ $self->pointed_hint('file-name-contains-wildcard-character',$item->pointer)
+ if $item->name =~ m{[*?]};
+
+ $self->pointed_hint('package-contains-compiled-glib-schema',$item->pointer)
+ if $item->name
+ =~ m{^ usr/share/ glib-[^/]+ /schemas/ gschemas[.]compiled $}x;
+
+ $self->pointed_hint('package-contains-file-in-etc-skel', $item->pointer)
+ if $item->dirname =~ m{^etc/skel/}
+ && $item->basename
+ !~ m{^ [.]bashrc | [.]bash_logout | [.]m?kshrc | [.]profile $}x;
+
+ $self->pointed_hint('package-contains-file-in-usr-share-hal',
+ $item->pointer)
+ if $item->dirname =~ m{^usr/share/hal/};
+
+ $self->pointed_hint('package-contains-icon-cache-in-generic-dir',
+ $item->pointer)
+ if $item->name eq 'usr/share/icons/hicolor/icon-theme.cache';
+
+ $self->pointed_hint('package-contains-python-dot-directory',$item->pointer)
+ if $item->dirname
+ =~ m{^ usr/lib/python[^/]+ / (?:dist|site)-packages / }x
+ && $item->name =~ m{ / [.][^/]+ / }x;
+
+ $self->pointed_hint('package-contains-python-coverage-file',$item->pointer)
+ if $item->basename eq '.coverage';
+
+ $self->pointed_hint('package-contains-python-doctree-file', $item->pointer)
+ if $item->basename =~ m{ [.]doctree (?:[.]gz)? $}x;
+
+ $self->pointed_hint(
+ 'package-contains-python-header-in-incorrect-directory',
+ $item->pointer)
+ if $item->dirname =~ m{^ usr/include/python3[.][01234567]/ }x
+ && $item->name =~ m{ [.]h $}x;
+
+ $self->pointed_hint('package-contains-python-hypothesis-example',
+ $item->pointer)
+ if $item->dirname =~ m{ /[.]hypothesis/examples/ }x;
+
+ $self->pointed_hint('package-contains-python-tests-in-global-namespace',
+ $item->pointer)
+ if $item->name
+ =~ m{^ usr/lib/python[^\/]+ / (?:dist|site)-packages / test_.+[.]py $}x;
+
+ $self->pointed_hint('package-contains-sass-cache-directory',$item->pointer)
+ if $item->name =~ m{ / [.]sass-cache / }x;
+
+ $self->pointed_hint('package-contains-eslint-config-file', $item->pointer)
+ if $item->basename =~ m{^ [.]eslintrc }x;
+
+ $self->pointed_hint('package-contains-npm-ignore-file', $item->pointer)
+ if $item->basename eq '.npmignore';
+
+ if (exists($PATH_DIRECTORIES{$item->dirname})) {
+
+ $self->pointed_hint('file-name-in-PATH-is-not-ASCII', $item->pointer)
+ if $item->basename !~ m{\A [[:ascii:]]++ \Z}xsm;
+
+ $self->pointed_hint('zero-byte-executable-in-path', $item->pointer)
+ if $item->is_regular_file
+ and $item->is_executable
+ and $item->size == 0;
+
+ } elsif (!valid_utf8($item->name)) {
+ $self->pointed_hint('shipped-file-without-utf8-name', $item->pointer);
+ }
+
+ return;
+}
+
+sub source {
+ my ($self) = @_;
+
+ unless ($self->processable->native) {
+
+ my @orig_non_utf8 = grep { !valid_utf8($_->name) }
+ @{$self->processable->orig->sorted_list};
+
+ $self->pointed_hint('upstream-file-without-utf8-name', $_->pointer)
+ for @orig_non_utf8;
+ }
+
+ my @patched = map { $_->name } @{$self->processable->patched->sorted_list};
+ my @orig = map { $_->name } @{$self->processable->orig->sorted_list};
+
+ my $lc= List::Compare->new(\@patched, \@orig);
+ my @created = $lc->get_Lonly;
+
+ my @non_utf8 = grep { !valid_utf8($_) } @created;
+
+ # exclude quilt directory
+ my @maintainer_fault = grep { !m{^.pc/} } @non_utf8;
+
+ if ($self->processable->native) {
+ $self->hint('native-source-file-without-utf8-name', $_)
+ for @maintainer_fault;
+
+ } else {
+ $self->hint('patched-file-without-utf8-name', $_)for @maintainer_fault;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/NonFree.pm b/lib/Lintian/Check/Files/NonFree.pm
new file mode 100644
index 0000000..32e5e7f
--- /dev/null
+++ b/lib/Lintian/Check/Files/NonFree.pm
@@ -0,0 +1,142 @@
+# files/non-free -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::NonFree;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $MD5SUM_DATA_FIELDS => 5;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub _md5sum_based_lintian_data {
+ my ($self, $filename) = @_;
+
+ my $data = $self->data->load($filename,qr/\s*\~\~\s*/);
+
+ my %md5sum_data;
+
+ for my $md5sum ($data->all) {
+
+ my $value = $data->value($md5sum);
+
+ my ($sha1, $sha256, $name, $reason, $link)
+ = split(/ \s* ~~ \s* /msx, $value, $MD5SUM_DATA_FIELDS);
+
+ die encode_utf8("Syntax error in $filename $.")
+ if any { !defined } ($sha1, $sha256, $name, $reason, $link);
+
+ $md5sum_data{$md5sum} = {
+ 'sha1' => $sha1,
+ 'sha256' => $sha256,
+ 'name' => $name,
+ 'reason' => $reason,
+ 'link' => $link,
+ };
+ }
+
+ return \%md5sum_data;
+}
+
+has NON_FREE_FILES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->_md5sum_based_lintian_data('cruft/non-free-files');
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # skip packages that declare non-free contents
+ return
+ if $self->processable->is_non_free;
+
+ my $nonfree = $self->NON_FREE_FILES->{$item->md5sum};
+ if (defined $nonfree) {
+ my $usualname = $nonfree->{'name'};
+ my $reason = $nonfree->{'reason'};
+ my $link = $nonfree->{'link'};
+
+ $self->pointed_hint(
+ 'license-problem-md5sum-non-free-file',
+ $item->pointer, "usual name is $usualname.",
+ $reason, "See also $link."
+ );
+ }
+
+ return;
+}
+
+# A list of known non-free flash executables
+my @flash_nonfree = (
+ qr/(?i)dewplayer(?:-\w+)?\.swf$/,
+ qr/(?i)(?:mp3|flv)player\.swf$/,
+ # Situation needs to be clarified:
+ # qr,(?i)multipleUpload\.swf$,
+ # qr,(?i)xspf_jukebox\.swf$,
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # skip packages that declare non-free contents
+ return
+ if $self->processable->is_non_free;
+
+ # non-free .swf files
+ $self->pointed_hint('non-free-flash', $item->pointer)
+ if any { $item->name =~ m{/$_} } @flash_nonfree;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/ObsoletePaths.pm b/lib/Lintian/Check/Files/ObsoletePaths.pm
new file mode 100644
index 0000000..b1d2ddd
--- /dev/null
+++ b/lib/Lintian/Check/Files/ObsoletePaths.pm
@@ -0,0 +1,92 @@
+# files/obsolete-paths -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::ObsoletePaths;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has OBSOLETE_PATHS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %obsolete;
+
+ my $data = $self->data->load('files/obsolete-paths',qr/\s*\->\s*/);
+
+ for my $key ($data->all) {
+
+ my $value = $data->value($key);
+
+ my ($newdir, $moreinfo) = split(/\s*\~\~\s*/, $value, 2);
+
+ $obsolete{$key} = {
+ 'newdir' => $newdir,
+ 'moreinfo' => $moreinfo,
+ 'match' => qr/$key/x,
+ 'olddir' => $key,
+ };
+ }
+
+ return \%obsolete;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # check for generic obsolete path
+ for my $obsolete_path (keys %{$self->OBSOLETE_PATHS}) {
+
+ my $obs_data = $self->OBSOLETE_PATHS->{$obsolete_path};
+ my $oldpathmatch = $obs_data->{'match'};
+
+ if ($item->name =~ m{$oldpathmatch}) {
+
+ my $oldpath = $obs_data->{'olddir'};
+ my $newpath = $obs_data->{'newdir'};
+ my $moreinfo = $obs_data->{'moreinfo'};
+
+ $self->pointed_hint('package-installs-into-obsolete-dir',
+ $item->pointer,": $oldpath -> $newpath", $moreinfo);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Openpgp.pm b/lib/Lintian/Check/Files/Openpgp.pm
new file mode 100644
index 0000000..dc421df
--- /dev/null
+++ b/lib/Lintian/Check/Files/Openpgp.pm
@@ -0,0 +1,51 @@
+# files/openpgp -- lintian check script -*- perl -*-
+
+# Copyright (C) 2022 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Openpgp;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('openpgp-file-has-implementation-specific-extension',
+ $item->pointer)
+ if $item->name =~ m{\.gpg$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Ownership.pm b/lib/Lintian/Check/Files/Ownership.pm
new file mode 100644
index 0000000..bbea4b9
--- /dev/null
+++ b/lib/Lintian/Check/Files/Ownership.pm
@@ -0,0 +1,74 @@
+# files/ownership -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Ownership;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SLASH => q{/};
+
+const my $MAXIMUM_LOW_RESERVED => 99;
+const my $MAXIMUM_HIGH_RESERVED => 64_999;
+const my $MINIMUM_HIGH_RESERVED => 60_000;
+const my $NOBODY => 65_534;
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('wrong-file-owner-uid-or-gid', $item->pointer,
+ $item->uid . $SLASH . $item->gid)
+ if out_of_bounds($item->uid)
+ || out_of_bounds($item->gid);
+
+ return;
+}
+
+sub out_of_bounds {
+ my ($id) = @_;
+
+ return 0
+ if $id <= $MAXIMUM_LOW_RESERVED;
+
+ return 0
+ if $id == $NOBODY;
+
+ return 0
+ if $id >= $MINIMUM_HIGH_RESERVED
+ && $id <= $MAXIMUM_HIGH_RESERVED;
+
+ return 1;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/P11Kit.pm b/lib/Lintian/Check/Files/P11Kit.pm
new file mode 100644
index 0000000..a128fa0
--- /dev/null
+++ b/lib/Lintian/Check/Files/P11Kit.pm
@@ -0,0 +1,54 @@
+# files/p11-kit -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::P11Kit;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if (
+ $item->name =~ m{^usr/share/p11-kit/modules/.}
+ && $item->name !~ m{\A usr/share/p11-kit/modules/
+ [[:alnum:]][[:alnum:]_.-]*\.module\Z
+ }xsm
+ ) {
+ $self->pointed_hint('incorrect-naming-of-pkcs11-module',
+ $item->pointer);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Pam.pm b/lib/Lintian/Check/Files/Pam.pm
new file mode 100644
index 0000000..c02cd4b
--- /dev/null
+++ b/lib/Lintian/Check/Files/Pam.pm
@@ -0,0 +1,50 @@
+# files/pam -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Pam;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # /etc/pam.conf
+ $self->pointed_hint('config-file-reserved', $item->pointer,
+ 'by libpam-runtime')
+ if $item->name =~ m{^etc/pam.conf$}
+ && $self->processable->name ne 'libpam-runtime';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Permissions.pm b/lib/Lintian/Check/Files/Permissions.pm
new file mode 100644
index 0000000..30cff5b
--- /dev/null
+++ b/lib/Lintian/Check/Files/Permissions.pm
@@ -0,0 +1,249 @@
+# files/permissions -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Permissions;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+
+const my $NOT_EQUAL => q{!=};
+
+const my $STANDARD_EXECUTABLE => oct(755);
+const my $SETGID_EXECUTABLE => oct(4754);
+const my $SET_USER_ID => oct(4000);
+const my $SET_GROUP_ID => oct(2000);
+
+const my $STANDARD_FILE => oct(644);
+const my $BACKUP_NINJA_FILE => oct(600);
+const my $SUDOERS_FILE => oct(440);
+const my $GAME_DATA => oct(664);
+
+const my $STANDARD_FOLDER => oct(755);
+const my $GAME_FOLDER => oct(2775);
+const my $VAR_LOCAL_FOLDER => oct(2775);
+const my $VAR_LOCK_FOLDER => oct(1777);
+const my $USR_SRC_FOLDER => oct(2775);
+
+const my $WORLD_READABLE => oct(444);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has component => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return path($self->processable->path)->basename;
+ }
+);
+
+has linked_against_libvga => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %linked_against_libvga;
+
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ for my $library (@{$item->elf->{NEEDED} // []}){
+
+ $linked_against_libvga{$item->name} = 1
+ if $library =~ m{^ libvga[.]so[.] }x;
+ }
+ }
+
+ return \%linked_against_libvga;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->is_file) {
+
+ if (
+ $item->is_executable
+ && $item->identity eq 'root/games'
+ && ( !$item->is_setgid
+ || !$item->all_bits_set($STANDARD_EXECUTABLE))
+ ) {
+
+ $self->pointed_hint(
+ 'non-standard-game-executable-perm',
+ $item->pointer,
+ $item->octal_permissions,
+ $NOT_EQUAL,
+ sprintf('%04o', $SET_GROUP_ID | $STANDARD_EXECUTABLE)
+ );
+
+ return;
+ }
+
+ $self->pointed_hint('executable-is-not-world-readable',
+ $item->pointer, $item->octal_permissions)
+ if $item->is_executable
+ && !$item->all_bits_set($WORLD_READABLE);
+
+ if ($item->is_setuid || $item->is_setgid) {
+
+ $self->pointed_hint('non-standard-setuid-executable-perm',
+ $item->pointer, $item->octal_permissions)
+ unless (($item->operm & ~($SET_USER_ID | $SET_GROUP_ID))
+ == $STANDARD_EXECUTABLE)
+ || $item->operm == $SETGID_EXECUTABLE;
+ }
+
+ # allow anything with suid in the name
+ return
+ if ($item->is_setuid || $item->is_setgid)
+ && $self->processable->name =~ / -suid /msx;
+
+ # program is using svgalib
+ return
+ if $item->is_setuid
+ && !$item->is_setgid
+ && $item->owner eq 'root'
+ && exists $self->linked_against_libvga->{$item->name};
+
+ # program is a setgid game
+ return
+ if $item->is_setgid
+ && !$item->is_setuid
+ && $item->group eq 'games'
+ && $item->name =~ m{^ usr/ (?:lib/)? games/ \S+ }msx;
+
+ if ($item->is_setuid || $item->is_setgid) {
+ $self->pointed_hint(
+ 'elevated-privileges', $item->pointer,
+ $item->octal_permissions, $item->identity
+ );
+
+ return;
+ }
+
+ if ( $item->is_executable
+ && $item->operm != $STANDARD_EXECUTABLE) {
+
+ $self->pointed_hint('non-standard-executable-perm',
+ $item->pointer, $item->octal_permissions, $NOT_EQUAL,
+ sprintf('%04o', $STANDARD_EXECUTABLE));
+
+ return;
+ }
+
+ if (!$item->is_executable) {
+
+ # game data
+ return
+ if $item->operm == $GAME_DATA
+ && $item->identity eq 'root/games'
+ && $item->name =~ m{^ var/ (?:lib/)? games/ \S+ }msx;
+
+ # GNAT compiler wants read-only Ada library information.
+ if ( $item->name =~ m{^ usr/lib/ .* [.]ali $}msx
+ && $item->operm != $WORLD_READABLE) {
+
+ $self->pointed_hint('bad-permissions-for-ali-file',
+ $item->pointer);
+
+ return;
+ }
+
+ # backupninja expects configurations files to be oct(600)
+ return
+ if $item->operm == $BACKUP_NINJA_FILE
+ && $item->name =~ m{^ etc/backup.d/ }msx;
+
+ if ($item->name =~ m{^ etc/sudoers.d/ }msx) {
+
+ # sudo requires sudoers files to be mode oct(440)
+ $self->pointed_hint(
+ 'bad-perm-for-file-in-etc-sudoers.d',$item->pointer,
+ $item->octal_permissions, $NOT_EQUAL,
+ sprintf('%04o', $SUDOERS_FILE)
+ )unless $item->operm == $SUDOERS_FILE;
+
+ return;
+ }
+
+ $self->pointed_hint(
+ 'non-standard-file-perm', $item->pointer,
+ $item->octal_permissions, $NOT_EQUAL,
+ sprintf('%04o', $STANDARD_FILE)
+ )unless $item->operm == $STANDARD_FILE;
+ }
+
+ }
+
+ if ($item->is_dir) {
+
+ # game directory with setgid bit
+ return
+ if $item->operm == $GAME_FOLDER
+ && $item->identity eq 'root/games'
+ && $item->name =~ m{^ var/ (?:lib/)? games/ \S+ }msx;
+
+ # shipping files here triggers warnings elsewhere
+ return
+ if $item->operm == $VAR_LOCK_FOLDER
+ && $item->identity eq 'root/root'
+ && ( $item->name =~ m{^ (?:var/)? tmp/ }msx
+ || $item->name eq 'var/lock/');
+
+ # shipping files here triggers warnings elsewhere
+ return
+ if $item->operm == $VAR_LOCAL_FOLDER
+ && $item->identity eq 'root/staff'
+ && $item->name eq 'var/local/';
+
+ # /usr/src created by base-files
+ return
+ if $item->operm == $USR_SRC_FOLDER
+ && $item->identity eq 'root/src'
+ && $item->name eq 'usr/src/';
+
+ $self->pointed_hint(
+ 'non-standard-dir-perm', $item->pointer,
+ $item->octal_permissions, $NOT_EQUAL,
+ sprintf('%04o', $STANDARD_FOLDER)
+ )unless $item->operm == $STANDARD_FOLDER;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Permissions/UsrLib.pm b/lib/Lintian/Check/Files/Permissions/UsrLib.pm
new file mode 100644
index 0000000..e465310
--- /dev/null
+++ b/lib/Lintian/Check/Files/Permissions/UsrLib.pm
@@ -0,0 +1,54 @@
+# files/permissions/usr-lib -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Permissions::UsrLib;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # see Bug#959037 for details
+ return
+ if $self->processable->type eq 'udeb';
+
+ return
+ unless $item->name =~ m{^usr/lib/};
+
+ $self->pointed_hint('executable-in-usr-lib', $item->pointer)
+ if $item->is_file && $item->is_executable;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Pkgconfig.pm b/lib/Lintian/Check/Files/Pkgconfig.pm
new file mode 100644
index 0000000..b2d555b
--- /dev/null
+++ b/lib/Lintian/Check/Files/Pkgconfig.pm
@@ -0,0 +1,121 @@
+# files/pkgconfig -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Pkgconfig;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::SlidingWindow;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+has PKG_CONFIG_BAD_REGEX => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('files/pkg-config-bad-regex',qr/~~~~~/);
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $architecture = $self->processable->fields->value('Architecture');
+
+ # arch-indep pkgconfig
+ if ( $item->is_regular_file
+ && $item->name=~ m{^usr/(lib(/[^/]+)?|share)/pkgconfig/[^/]+\.pc$}){
+
+ my $prefix = $1;
+ my $pkg_config_arch = $2 // $EMPTY;
+ $pkg_config_arch =~ s{\A/}{}ms;
+
+ $self->pointed_hint('pkg-config-unavailable-for-cross-compilation',
+ $item->pointer)
+ if $prefix eq 'lib';
+
+ open(my $fd, '<:raw', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $sfd = Lintian::SlidingWindow->new;
+ $sfd->handle($fd);
+
+ BLOCK:
+ while (my $block = $sfd->readwindow) {
+ # remove comment line
+ $block =~ s/\#\V*//gsm;
+ # remove continuation line
+ $block =~ s/\\\n/ /gxsm;
+ # check if pkgconfig file include path point to
+ # arch specific dir
+
+ my $DEB_HOST_MULTIARCH
+ = $self->data->architectures->deb_host_multiarch;
+ for my $madir (values %{$DEB_HOST_MULTIARCH}) {
+
+ next
+ if $pkg_config_arch eq $madir;
+
+ if ($block =~ m{\W\Q$madir\E(\W|$)}xms) {
+
+ $self->pointed_hint('pkg-config-multi-arch-wrong-dir',
+ $item->pointer,
+ 'full text contains architecture specific dir',$madir);
+
+ last;
+ }
+ }
+
+ for my $pattern ($self->PKG_CONFIG_BAD_REGEX->all) {
+
+ while($block =~ m{$pattern}xmsg) {
+
+ my $context = $1;
+
+ $self->pointed_hint('pkg-config-bad-directive',
+ $item->pointer,$context);
+ }
+ }
+ }
+ close($fd);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/PrivacyBreach.pm b/lib/Lintian/Check/Files/PrivacyBreach.pm
new file mode 100644
index 0000000..8d75623
--- /dev/null
+++ b/lib/Lintian/Check/Files/PrivacyBreach.pm
@@ -0,0 +1,420 @@
+# files/privacy-breach -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::PrivacyBreach;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::SlidingWindow;
+
+const my $BLOCKSIZE => 16_384;
+const my $EMPTY => q{};
+
+const my $PRIVACY_BREAKER_WEBSITES_FIELDS => 3;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has PRIVACY_BREAKER_WEBSITES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %website;
+
+ my $data
+ = $self->data->load('files/privacy-breaker-websites',qr/\s*\~\~/);
+
+ for my $key ($data->all) {
+
+ my $value = $data->value($key);
+
+ my ($pattern, $tag, $suggest)
+ = split(/ \s* ~~ \s* /msx,
+ $value,$PRIVACY_BREAKER_WEBSITES_FIELDS);
+
+ $tag //= $EMPTY;
+
+ # trim both ends
+ $tag =~ s/^\s+|\s+$//g;
+
+ $tag = $key
+ unless length $tag;
+
+ $website{$key} = {
+ 'tag' => $tag,
+ 'regexp' => qr/$pattern/xsm,
+ };
+
+ $website{$key}{'suggest'} = $suggest
+ if defined $suggest;
+ }
+
+ return \%website;
+ }
+);
+
+has PRIVACY_BREAKER_FRAGMENTS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %fragment;
+
+ my $data
+ = $self->data->load('files/privacy-breaker-fragments',qr/\s*\~\~/);
+
+ for my $key ($data->all) {
+
+ my $value = $data->value($key);
+
+ my ($pattern, $tag) = split(/\s*\~\~\s*/, $value, 2);
+
+ $fragment{$key} = {
+ 'keyword' => $key,
+ 'regex' => qr/$pattern/xsm,
+ 'tag' => $tag,
+ };
+ }
+
+ return \%fragment;
+ }
+);
+
+has PRIVACY_BREAKER_TAG_ATTR => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %attribute;
+
+ my $data
+ = $self->data->load('files/privacy-breaker-tag-attr',qr/\s*\~\~\s*/);
+
+ for my $key ($data->all) {
+
+ my $value = $data->value($key);
+
+ my ($keywords,$pattern) = split(/\s*\~\~\s*/, $value, 2);
+
+ $pattern =~ s/&URL/(?:(?:ht|f)tps?:)?\/\/[^"\r\n]*/g;
+
+ my @keywordlist;
+
+ my @keywordsorraw = split(/\s*\|\|\s*/,$keywords);
+
+ for my $keywordor (@keywordsorraw) {
+ my @keywordsandraw = split(/\s*&&\s*/,$keywordor);
+ push(@keywordlist, \@keywordsandraw);
+ }
+
+ $attribute{$key} = {
+ 'keywords' => \@keywordlist,
+ 'regex' => qr/$pattern/xsm,
+ };
+ }
+
+ return \%attribute;
+ }
+);
+
+sub detect_privacy_breach {
+ my ($self, $file) = @_;
+
+ my %privacybreachhash;
+
+ return
+ unless $file->is_regular_file;
+
+ open(my $fd, '<:raw', $file->unpacked_path)
+ or die encode_utf8('Cannot open ' . $file->unpacked_path);
+
+ my $sfd = Lintian::SlidingWindow->new;
+ $sfd->handle($fd);
+ $sfd->blocksize($BLOCKSIZE);
+ $sfd->blocksub(sub { $_ = lc; });
+
+ while (my $lowercase = $sfd->readwindow) {
+ # strip comments
+ for my $x (qw(<!--(?!\[if).*?--\s*> /\*(?!@cc_on).*?\*/)) {
+ $lowercase =~ s/$x//gs;
+ }
+
+ # keep sorted; otherwise 'exists' below produces inconsistent output
+ for my $keyword (sort keys %{$self->PRIVACY_BREAKER_FRAGMENTS}) {
+
+ if ($lowercase =~ / \Q$keyword\E /msx) {
+ my $keyvalue= $self->PRIVACY_BREAKER_FRAGMENTS->{$keyword};
+ my $regex = $keyvalue->{'regex'};
+
+ if ($lowercase =~ m{($regex)}) {
+ my $capture = $1;
+ my $breaker_tag = $keyvalue->{'tag'};
+
+ unless (exists $privacybreachhash{'tag-'.$breaker_tag}){
+
+ $privacybreachhash{'tag-'.$breaker_tag} = 1;
+
+ $self->pointed_hint($breaker_tag, $file->pointer,
+ "(choke on: $capture)");
+ }
+ }
+ }
+ }
+
+ for my $x (
+ qw(src="http src="ftp src="// data-href="http data-href="ftp
+ data-href="// codebase="http codebase="ftp codebase="// data="http
+ data="ftp data="// poster="http poster="ftp poster="// <link @import)
+ ) {
+ next
+ unless $lowercase =~ / \Q$x\E /msx;
+
+ $self->detect_generic_privacy_breach($lowercase,
+ \%privacybreachhash,$file);
+
+ last;
+ }
+ }
+
+ close($fd);
+ return;
+}
+
+# According to html norm src attribute is used by tags:
+#
+# audio(v5+), embed (v5+), iframe (v4), frame, img, input, script, source, track(v5), video (v5)
+# Add other tags with src due to some javascript code:
+# div due to div.js
+# div data-href due to jquery
+# css with @import
+sub detect_generic_privacy_breach {
+ my ($self, $block, $privacybreachhash, $file) = @_;
+ my %matchedkeyword;
+
+ # now check generic tag
+ TYPE:
+ for my $type (sort keys %{$self->PRIVACY_BREAKER_TAG_ATTR}) {
+ my $keyvalue = $self->PRIVACY_BREAKER_TAG_ATTR->{$type};
+ my $keywords = $keyvalue->{'keywords'};
+
+ my $orblockok = 0;
+ ORBLOCK:
+ for my $keywordor (@{$keywords}) {
+ ANDBLOCK:
+ for my $keyword (@{$keywordor}) {
+
+ my $thiskeyword = $matchedkeyword{$keyword};
+ if(!defined($thiskeyword)) {
+ if ($block =~ / \Q$keyword\E /msx) {
+ $matchedkeyword{$keyword} = 1;
+ $orblockok = 1;
+ }else {
+ $matchedkeyword{$keyword} = 0;
+ $orblockok = 0;
+ next ORBLOCK;
+ }
+ }
+ if($matchedkeyword{$keyword} == 0) {
+ $orblockok = 0;
+ next ORBLOCK;
+ }else {
+ $orblockok = 1;
+ }
+ }
+ if($orblockok == 1) {
+ last ORBLOCK;
+ }
+ }
+ if($orblockok == 0) {
+ next TYPE;
+ }
+
+ my $regex = $keyvalue->{'regex'};
+
+ while($block=~m{$regex}g){
+ $self->check_tag_url_privacy_breach($1, $2, $3,$privacybreachhash,
+ $file);
+ }
+ }
+ return;
+}
+
+sub is_localhost {
+ my ($urlshort) = @_;
+ if( $urlshort =~ m{^(?:[^/]+@)?localhost(?:[:][^/]+)?/}i
+ || $urlshort =~ m{^(?:[^/]+@)?::1(?:[:][^/]+)?/}i
+ || $urlshort =~ m{^(?:[^/]+@)?127(?:\.\d{1,3}){3}(?:[:][^/]+)?/}i) {
+ return 1;
+ }else {
+ return 0;
+ }
+}
+
+sub check_tag_url_privacy_breach {
+ my ($self, $fulltag, $tagattr, $url,$privacybreachhash, $file) = @_;
+
+ my $website = $url;
+ # detect also "^//" trick
+ $website =~ s{^"?(?:(?:ht|f)tps?:)?//}{};
+ $website =~ s/"?$//;
+
+ if (is_localhost($website)){
+ # do nothing ok
+ return;
+ }
+
+ # reparse fulltag for rel
+ if ($tagattr eq 'link') {
+
+ my $rel = $fulltag;
+ $rel =~ m{<link
+ (?:\s[^>]+)? \s+
+ rel="([^"\r\n]*)"
+ [^>]*
+ >}xismog;
+ my $relcontent = $1;
+
+ if (defined($relcontent)) {
+ # See, for example, https://www.w3schools.com/tags/att_link_rel.asp
+ my %allowed = (
+ 'alternate' => 1, # #891301
+ 'author' => 1, # #891301
+ 'bookmark' => 1, # #746656
+ 'canonical' => 1, # #762753
+ 'copyright' => 1, # #902919
+ 'edituri' => 1, # #902919
+ 'generator' => 1, # #891301
+ 'generator-home' => 1, # texinfo
+ 'help' => 1, # #891301
+ 'license' => 1, # #891301
+ 'next' => 1, # #891301
+ 'prev' => 1, # #891301
+ 'schema.dct' => 1, # #736992
+ 'search' => 1, # #891301
+ );
+
+ return
+ if ($allowed{$relcontent});
+
+ if ($relcontent eq 'alternate') {
+ my $type = $fulltag;
+ $type =~ m{<link
+ (?:\s[^>]+)? \s+
+ type="([^"\r\n]*)"
+ [^>]*
+ >}xismog;
+ my $typecontent = $1;
+ if($typecontent eq 'application/rdf+xml') {
+ # see #79991
+ return;
+ }
+ }
+ }
+ }
+
+ # False positive
+ # legal.xml file of gnome
+ # could be replaced by a link to local file but not really a privacy breach
+ if( $file->basename eq 'legal.xml'
+ && $tagattr eq 'link'
+ && $website =~ m{^creativecommons.org/licenses/}) {
+
+ return;
+ }
+
+ # In Mallard XML, <link> is a clickable anchor that will not be
+ # followed automatically.
+ if( $file->basename =~ '.xml$'
+ && $tagattr eq 'link'
+ && $file->bytes=~ qr{ xmlns="http://projectmallard\.org/1\.0/"}) {
+
+ return;
+ }
+
+ # track well known site
+ for my $breaker (sort keys %{$self->PRIVACY_BREAKER_WEBSITES}) {
+
+ my $value = $self->PRIVACY_BREAKER_WEBSITES->{$breaker};
+ my $regex = $value->{'regexp'};
+
+ if ($website =~ m{$regex}mxs) {
+
+ unless (exists $privacybreachhash->{'tag-'.$breaker}) {
+
+ my $tag = $value->{'tag'};
+ my $suggest = $value->{'suggest'} // $EMPTY;
+
+ $privacybreachhash->{'tag-'.$breaker}= 1;
+ $self->pointed_hint($tag, $file->pointer, $suggest, "($url)");
+ }
+
+ # do not go to generic case
+ return;
+ }
+ }
+
+ # generic case
+ unless (exists $privacybreachhash->{'tag-generic-'.$website}){
+
+ $self->pointed_hint('privacy-breach-generic', $file->pointer,
+ "[$fulltag]","($url)");
+ $privacybreachhash->{'tag-generic-'.$website} = 1;
+ }
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $file) = @_;
+
+ # html/javascript
+ if ( $file->is_file
+ && $file->name =~ m/\.(?:x?html?\d?|js|xht|xml|css)$/i) {
+
+ if( $self->processable->source_name eq 'josm'
+ and $file->basename eq 'defaultpresets.xml') {
+ # false positive
+
+ } else {
+ $self->detect_privacy_breach($file);
+ }
+ }
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Scripts.pm b/lib/Lintian/Check/Files/Scripts.pm
new file mode 100644
index 0000000..3dff34e
--- /dev/null
+++ b/lib/Lintian/Check/Files/Scripts.pm
@@ -0,0 +1,57 @@
+# files/scripts -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Scripts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # language extensions
+ if (
+ $item->name =~ m{\A
+ (?:usr/)?(?:s?bin|games)/[^/]+\.
+ (?:p[ly]|php|rb|[bc]?sh|tcl)
+ \Z}xsm
+ ) {
+ $self->pointed_hint('script-with-language-extension', $item->pointer);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Sgml.pm b/lib/Lintian/Check/Files/Sgml.pm
new file mode 100644
index 0000000..fd4ace2
--- /dev/null
+++ b/lib/Lintian/Check/Files/Sgml.pm
@@ -0,0 +1,48 @@
+# files/sgml -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Sgml;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # /usr/lib/sgml
+ $self->pointed_hint('file-in-usr-lib-sgml', $item->pointer)
+ if $item->name =~ m{^usr/lib/sgml/\S};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/SourceMissing.pm b/lib/Lintian/Check/Files/SourceMissing.pm
new file mode 100644
index 0000000..6ae9f03
--- /dev/null
+++ b/lib/Lintian/Check/Files/SourceMissing.pm
@@ -0,0 +1,286 @@
+# files/source-missing -- lintian check script -*- perl -*-
+#
+# based on debhelper check,
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::SourceMissing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename qw(basename);
+use List::SomeUtils qw(first_value);
+use List::UtilsBy qw(max_by);
+
+# very long line lengths
+const my $VERY_LONG_LINE_LENGTH => 512;
+
+const my $EMPTY => q{};
+const my $DOLLAR => q{$};
+const my $DOT => q{.};
+const my $DOUBLE_DOT => q{..};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ if $item->dirname =~ m{^debian/missing-sources/};
+
+ # prebuilt-file or forbidden file type
+ $self->pointed_hint('source-contains-prebuilt-wasm-binary', $item->pointer)
+ if $item->file_type =~ m{^WebAssembly \s \(wasm\) \s binary \s module}x;
+
+ $self->pointed_hint('source-contains-prebuilt-windows-binary',
+ $item->pointer)
+ if $item->file_type
+ =~ m{\b(?:PE(?:32|64)|(?:MS-DOS|COM)\s executable)\b}x;
+
+ $self->pointed_hint('source-contains-prebuilt-silverlight-object',
+ $item->pointer)
+ if $item->file_type =~ m{^Zip \s archive \s data}x
+ && $item->name =~ m{(?i)\.xac$}x;
+
+ if ($item->file_type =~ m{^python \s \d(\.\d+)? \s byte-compiled}x) {
+
+ $self->pointed_hint('source-contains-prebuilt-python-object',
+ $item->pointer);
+
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source($item,
+ {'.py' => '(?i)(?:\.cpython-\d{2}|\.pypy)?\.py[co]$'});
+ }
+
+ if ($item->file_type =~ m{\bELF\b}x) {
+ $self->pointed_hint('source-contains-prebuilt-binary', $item->pointer);
+
+ my %patterns = map {
+ $_ =>
+'(?i)(?:[\.-](?:bin|elf|e|hs|linux\d+|oo?|or|out|so(?:\.\d+)*)|static|_o\.golden)?$'
+ } qw(.asm .c .cc .cpp .cxx .f .F .i .ml .rc .S);
+
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source($item, \%patterns);
+ }
+
+ if ($item->file_type =~ m{^Macromedia \s Flash}x) {
+
+ $self->pointed_hint('source-contains-prebuilt-flash-object',
+ $item->pointer);
+
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source($item, {'.as' => '(?i)\.swf$'});
+ }
+
+ if ( $item->file_type =~ m{^Composite \s Document \s File}x
+ && $item->name =~ m{(?i)\.fla$}x) {
+
+ $self->pointed_hint('source-contains-prebuilt-flash-project',
+ $item->pointer);
+
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source($item, {'.as' => '(?i)\.fla$'});
+ }
+
+ # see #745152
+ # Be robust check also .js
+ if ($item->basename eq 'deployJava.js') {
+ if (
+ lc $item->decoded_utf8
+ =~ m/(?:\A|\v)\s*var\s+deployJava\s*=\s*function/xmsi) {
+
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source($item,
+ {'.txt' => '(?i)\.js$', $EMPTY => $EMPTY});
+
+ return;
+ }
+ }
+
+ # do not forget to change also $JS_EXT in file.pm
+ if ($item->name
+ =~ m{(?i)[-._](?:compiled|compressed|lite|min|pack(?:ed)?|prod|umd|yc)\.js$}x
+ ) {
+
+ $self->pointed_hint('source-contains-prebuilt-javascript-object',
+ $item->pointer);
+ my %patterns = map {
+ $_ =>
+'(?i)(?:[-._](?:compiled|compressed|lite|min|pack(?:ed)?|prod|umd|yc))?\.js$'
+ } qw(.js _orig.js .js.orig .src.js -src.js .debug.js -debug.js -nc.js);
+
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source($item, \%patterns);
+
+ return;
+ }
+
+ my @lines = split(/\n/, $item->bytes);
+ my %line_length;
+ my %semicolon_count;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ $line_length{$position} = length $line;
+ $semicolon_count{$position} = ($line =~ tr/;/;/);
+
+ } continue {
+ ++$position;
+ }
+
+ my $longest = max_by { $line_length{$_} } keys %line_length;
+ my $most = max_by { $semicolon_count{$_} } keys %semicolon_count;
+
+ return
+ if !defined $longest || $line_length{$longest} <= $VERY_LONG_LINE_LENGTH;
+
+ if ($item->basename =~ m{\.js$}i) {
+
+ $self->pointed_hint('source-contains-prebuilt-javascript-object',
+ $item->pointer);
+
+ # Check for missing source. It will check
+ # for the source file in well known directories
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source(
+ $item,
+ {
+ '.debug.js' => '(?i)\.js$',
+ '-debug.js' => '(?i)\.js$',
+ $EMPTY => $EMPTY
+ }
+ );
+ }
+
+ if ($item->basename =~ /\.(?:x?html?\d?|xht)$/i) {
+
+ # html file
+ $self->pointed_hint('source-is-missing', $item->pointer)
+ unless $self->find_source($item, {'.fragment.js' => $DOLLAR});
+ }
+
+ return;
+}
+
+sub find_source {
+ my ($self, $item, $patternref) = @_;
+
+ $patternref //= {};
+
+ return undef
+ unless $item->is_regular_file;
+
+ return undef
+ if $self->processable->is_non_free;
+
+ my %patterns = %{$patternref};
+
+ my @alternatives;
+ for my $replacement (keys %patterns) {
+
+ my $newname = $item->basename;
+
+ # empty pattern would repeat the last regex compiled
+ my $pattern = $patterns{$replacement};
+ $newname =~ s/$pattern/$replacement/
+ if length $pattern;
+
+ push(@alternatives, $newname)
+ if length $newname;
+ }
+
+ my $index = $self->processable->patched;
+ my @candidates;
+
+ # add standard locations
+ push(@candidates,
+ $index->resolve_path('debian/missing-sources/' . $item->name));
+ push(@candidates,
+ $index->resolve_path('debian/missing-sources/' . $item->basename));
+
+ my $dirname = $item->dirname;
+ my $parentname = basename($dirname);
+
+ my @absolute = (
+ # libtool
+ '.libs',
+ ".libs/$dirname",
+ # mathjax
+ 'unpacked',
+ # for missing source set in debian
+ 'debian',
+ 'debian/missing-sources',
+ "debian/missing-sources/$dirname"
+ );
+
+ for my $absolute (@absolute) {
+ push(@candidates, $index->resolve_path("$absolute/$_"))
+ for @alternatives;
+ }
+
+ my @relative = (
+ # likely in current dir
+ $DOT,
+ # for binary object built by libtool
+ $DOUBLE_DOT,
+ # maybe in src subdir
+ './src',
+ # maybe in ../src subdir
+ '../src',
+ "../../src/$parentname",
+ # emscripten
+ './flash-src/src/net/gimite/websocket',
+ );
+
+ for my $relative (@relative) {
+ push(@candidates, $item->resolve_path("$relative/$_"))
+ for @alternatives;
+ }
+
+ my @found = grep { defined } @candidates;
+
+ # careful with behavior around empty arrays
+ my $source = first_value { $_->name ne $item->name } @found;
+
+ return $source;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Special.pm b/lib/Lintian/Check/Files/Special.pm
new file mode 100644
index 0000000..7a59006
--- /dev/null
+++ b/lib/Lintian/Check/Files/Special.pm
@@ -0,0 +1,50 @@
+# files/special -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Special;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $item->is_file || $item->is_dir || $item->is_symlink;
+
+ $self->pointed_hint('special-file', $item->pointer,
+ sprintf('%04o',$item->operm));
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/SymbolicLinks.pm b/lib/Lintian/Check/Files/SymbolicLinks.pm
new file mode 100644
index 0000000..0edcde2
--- /dev/null
+++ b/lib/Lintian/Check/Files/SymbolicLinks.pm
@@ -0,0 +1,229 @@
+# files/symbolic-links -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::SymbolicLinks;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SLASH => q{/};
+const my $DOT => q{.};
+const my $DOUBLE_DOT => q{..};
+const my $VERTICAL_BAR => q{|};
+const my $ARROW => q{->};
+
+# an OR (|) regex of all compressed extension
+has COMPRESS_FILE_EXTENSIONS_OR_ALL => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $COMPRESS_FILE_EXTENSIONS
+ = $self->data->load('files/compressed-file-extensions',qr/\s+/);
+
+ my $text = join($VERTICAL_BAR,
+ (map { quotemeta } $COMPRESS_FILE_EXTENSIONS->all));
+
+ return qr/$text/;
+ }
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_symlink;
+
+ # absolute links cannot be resolved
+ if ($item->link =~ m{^/}) {
+
+ # allow /dev/null link target for masked systemd service files
+ $self->pointed_hint('absolute-symbolic-link-target-in-source',
+ $item->pointer, $item->link)
+ unless $item->link eq '/dev/null';
+ }
+
+ # some relative links cannot be resolved inside the source
+ $self->pointed_hint('wayward-symbolic-link-target-in-source',
+ $item->pointer, $item->link)
+ unless defined $_->link_normalized || $item->link =~ m{^/};
+
+ return;
+}
+
+sub is_tmp_path {
+ my ($path) = @_;
+
+ return 1
+ if $path =~ m{^tmp/.}
+ || $path =~ m{^(?:var|usr)/tmp/.}
+ || $path =~ m{^/dev/shm/};
+
+ return 0;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_symlink;
+
+ my $mylink = $item->link;
+ $self->pointed_hint('symlink-has-double-slash', $item->pointer,$item->link)
+ if $mylink =~ s{//+}{/}g;
+
+ $self->pointed_hint('symlink-ends-with-slash', $item->pointer, $item->link)
+ if $mylink =~ s{(.)/$}{$1};
+
+ # determine top-level directory of file
+ $item->name =~ m{^/?([^/]*)};
+ my $filetop = $1;
+
+ if ($mylink =~ m{^/([^/]*)}) {
+ my $flinkname = substr($mylink,1);
+ # absolute link, including link to /
+ # determine top-level directory of link
+ my $linktop = $1;
+
+ if ($self->processable->type ne 'udeb' and $filetop eq $linktop) {
+ # absolute links within one toplevel directory are _not_ ok!
+ $self->pointed_hint('absolute-symlink-in-top-level-folder',
+ $item->pointer, $item->link);
+ }
+
+ my $BUILD_PATH_REGEX
+ = $self->data->load('files/build-path-regex',qr/~~~~~/);
+
+ for my $pattern ($BUILD_PATH_REGEX->all) {
+
+ $self->pointed_hint('symlink-target-in-build-tree',
+ $item->pointer, $mylink)
+ if $flinkname =~ m{$pattern}xms;
+ }
+
+ $self->pointed_hint('symlink-target-in-tmp', $item->pointer,$mylink)
+ if is_tmp_path($flinkname);
+
+ # Any other case is already definitely non-recursive
+ $self->pointed_hint('symlink-is-self-recursive', $item->pointer,
+ $item->link)
+ if $mylink eq $SLASH;
+
+ } else {
+ # relative link, we can assume from here that the link
+ # starts nor ends with /
+
+ my @filecomponents = split(m{/}, $item->name);
+ # chop off the name of the symlink
+ pop @filecomponents;
+
+ my @linkcomponents = split(m{/}, $mylink);
+
+ # handle `../' at beginning of $item->link
+ my ($lastpop, $linkcomponent);
+ while ($linkcomponent = shift @linkcomponents) {
+ if ($linkcomponent eq $DOT) {
+ $self->pointed_hint('symlink-contains-spurious-segments',
+ $item->pointer, $item->link)
+ unless $mylink eq $DOT;
+ next;
+ }
+ last if $linkcomponent ne $DOUBLE_DOT;
+ if (@filecomponents) {
+ $lastpop = pop @filecomponents;
+ } else {
+ $self->pointed_hint('symlink-has-too-many-up-segments',
+ $item->pointer, $item->link);
+ goto NEXT_LINK;
+ }
+ }
+
+ if (!defined $linkcomponent) {
+ # After stripping all starting .. components, nothing left
+ $self->pointed_hint('symlink-is-self-recursive', $item->pointer,
+ $item->link);
+ }
+
+ # does the link go up and then down into the same
+ # directory? (lastpop indicates there was a backref
+ # at all, no linkcomponent means the symlink doesn't
+ # get up anymore)
+ if ( defined $lastpop
+ && defined $linkcomponent
+ && $linkcomponent eq $lastpop) {
+ $self->pointed_hint('lengthy-symlink', $item->pointer,$item->link);
+ }
+
+ unless (@filecomponents) {
+ # we've reached the root directory
+ if ( ($self->processable->type ne 'udeb')
+ && (!defined $linkcomponent)
+ || ($filetop ne $linkcomponent)) {
+
+ # relative link into other toplevel directory.
+ # this hits a relative symbolic link in the root too.
+ $self->pointed_hint('relative-symlink', $item->pointer,
+ $item->link);
+ }
+ }
+
+ # check additional segments for mistakes like `foo/../bar/'
+ foreach (@linkcomponents) {
+ if ($_ eq $DOUBLE_DOT || $_ eq $DOT) {
+ $self->pointed_hint('symlink-contains-spurious-segments',
+ $item->pointer, $item->link);
+ last;
+ }
+ }
+ }
+ NEXT_LINK:
+
+ my $pattern = $self->COMPRESS_FILE_EXTENSIONS_OR_ALL;
+
+ # symlink pointing to a compressed file
+ if ($item->link =~ qr{ [.] ($pattern) \s* $}x) {
+
+ my $extension = $1;
+
+ # symlink has correct extension?
+ $self->pointed_hint('compressed-symlink-with-wrong-ext',
+ $item->pointer, $item->link)
+ unless $item->name =~ qr{[.]$extension\s*$};
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/SymbolicLinks/Broken.pm b/lib/Lintian/Check/Files/SymbolicLinks/Broken.pm
new file mode 100644
index 0000000..39ae2d2
--- /dev/null
+++ b/lib/Lintian/Check/Files/SymbolicLinks/Broken.pm
@@ -0,0 +1,119 @@
+# files/symbolic-links/broken -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2011 Niels Thykier
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::SymbolicLinks::Broken;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename qw(dirname);
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $ASTERISK => q{*};
+
+has wildcard_links => (is => 'rw', default => sub{ [] });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_symlink;
+
+ # target relative to the package root
+ my $path = $item->link_normalized;
+
+ # unresolvable link
+ unless (defined $path) {
+
+ $self->pointed_hint('package-contains-unsafe-symlink', $item->pointer);
+ return;
+ }
+
+ # will always have links to the package root (although
+ # self-recursive and possibly not very useful)
+ return
+ if $path eq $EMPTY;
+
+ # If it contains a "*" it probably a bad
+ # ln -s target/*.so link expansion. We do not bother looking
+ # for other broken symlinks as people keep adding new special
+ # cases and it is not worth it.
+ push(@{$self->wildcard_links}, $item)
+ if index($item->link, $ASTERISK) >= 0;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ unless @{$self->wildcard_links};
+
+ # get prerequisites from same source package
+ my @prerequisites
+ = @{$self->group->direct_dependencies($self->processable)};
+
+ for my $item (@{$self->wildcard_links}){
+
+ # target relative to the package root
+ my $path = $item->link_normalized;
+
+ # destination is in the package
+ next
+ if $self->processable->installed->lookup($path)
+ || $self->processable->installed->lookup("$path/");
+
+ # does the link point to any prerequisites in same source package
+ next
+ if
+ any {$_->installed->lookup($path) || $_->installed->lookup("$path/")}
+ @prerequisites;
+
+ # link target
+ my $target = $item->link;
+
+ # strip leading slashes for reporting
+ $target =~ s{^/+}{};
+
+ # nope - not found in any of our direct dependencies. Ergo it is
+ # a broken "ln -s target/*.so link" expansion.
+ $self->pointed_hint('package-contains-broken-symlink-wildcard',
+ $item->pointer, $target);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Unicode/Trojan.pm b/lib/Lintian/Check/Files/Unicode/Trojan.pm
new file mode 100644
index 0000000..5c4f2e1
--- /dev/null
+++ b/lib/Lintian/Check/Files/Unicode/Trojan.pm
@@ -0,0 +1,134 @@
+# files/unicode/trojan -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Unicode::Trojan;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(decode_utf8 encode_utf8 valid_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $DOUBLE_QUOTE => q{"};
+
+const my %NAMES_BY_CHARACTER => (
+ qq{\N{ARABIC LETTER MARK}} => 'ARABIC LETTER MARK', # U+061C
+ qq{\N{LEFT-TO-RIGHT MARK}} => 'LEFT-TO-RIGHT MARK', # U+200E
+ qq{\N{RIGHT-TO-LEFT MARK}} => 'RIGHT-TO-LEFT MARK', # U+200F
+ qq{\N{LEFT-TO-RIGHT EMBEDDING}} => 'LEFT-TO-RIGHT EMBEDDING', # U+202A
+ qq{\N{RIGHT-TO-LEFT EMBEDDING}} => 'RIGHT-TO-LEFT EMBEDDING', # U+202B
+ qq{\N{POP DIRECTIONAL FORMATTING}} =>'POP DIRECTIONAL FORMATTING', # U+202C
+ qq{\N{LEFT-TO-RIGHT OVERRIDE}} => 'LEFT-TO-RIGHT OVERRIDE', # U+202D
+ qq{\N{RIGHT-TO-LEFT OVERRIDE}} => 'RIGHT-TO-LEFT OVERRIDE', # U+202E
+ qq{\N{LEFT-TO-RIGHT ISOLATE}} => 'LEFT-TO-RIGHT ISOLATE', # U+2066
+ qq{\N{RIGHT-TO-LEFT ISOLATE}} => 'RIGHT-TO-LEFT ISOLATE', # U+2067
+ qq{\N{FIRST STRONG ISOLATE}} => 'FIRST STRONG ISOLATE', # U+2068
+ qq{\N{POP DIRECTIONAL ISOLATE}} => 'POP DIRECTIONAL ISOLATE', # U+2069
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ $self->check_for_trojan($item);
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->check_for_trojan($item);
+
+ return;
+}
+
+sub check_for_trojan {
+ my ($self, $item) = @_;
+
+ if (valid_utf8($item->name)) {
+
+ my $decoded_name = decode_utf8($item->name);
+
+ # all file names
+ for my $character (keys %NAMES_BY_CHARACTER) {
+
+ $self->pointed_hint(
+ 'unicode-trojan',
+ $item->pointer,
+ 'File name',
+ sprintf('U+%vX', $character),
+ $DOUBLE_QUOTE. $NAMES_BY_CHARACTER{$character}. $DOUBLE_QUOTE
+ ) if $decoded_name =~ m{\Q$character\E};
+ }
+ }
+
+ return
+ unless $item->is_script;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ next
+ unless valid_utf8($line);
+
+ my $decoded = decode_utf8($line);
+
+ my $pointer = $item->pointer($position);
+
+ for my $character (keys %NAMES_BY_CHARACTER) {
+
+ $self->pointed_hint(
+ 'unicode-trojan',
+ $pointer,
+ 'Contents',
+ sprintf('U+%vX', $character),
+ $DOUBLE_QUOTE. $NAMES_BY_CHARACTER{$character}. $DOUBLE_QUOTE
+ )if $decoded =~ m{\Q$character\E};
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Unwanted.pm b/lib/Lintian/Check/Files/Unwanted.pm
new file mode 100644
index 0000000..779e4f5
--- /dev/null
+++ b/lib/Lintian/Check/Files/Unwanted.pm
@@ -0,0 +1,55 @@
+# files/unwanted -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Unwanted;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ $self->pointed_hint('backup-file-in-package', $item->pointer)
+ if $item->name =~ /~$/
+ || $item->name =~ m{\#[^/]+\#$}
+ || $item->name =~ m{/\.[^/]+\.swp$};
+
+ $self->pointed_hint('nfs-temporary-file-in-package', $item->pointer)
+ if $item->name =~ m{/\.nfs[^/]+$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/UsrMerge.pm b/lib/Lintian/Check/Files/UsrMerge.pm
new file mode 100644
index 0000000..be5a06d
--- /dev/null
+++ b/lib/Lintian/Check/Files/UsrMerge.pm
@@ -0,0 +1,53 @@
+# files/usr-merge -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::UsrMerge;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $quotedpath = quotemeta($item->name);
+
+ $self->pointed_hint('package-contains-usr-unmerged-pathnames',
+ $item->pointer)
+ if $item->name =~ m{^(?:bin|sbin|lib.*)/.+$}
+ && !$item->is_symlink
+ && !$item->is_dir
+ && $item->link !~ m{^usr/$quotedpath$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Files/Vcs.pm b/lib/Lintian/Check/Files/Vcs.pm
new file mode 100644
index 0000000..2f5b8f5
--- /dev/null
+++ b/lib/Lintian/Check/Files/Vcs.pm
@@ -0,0 +1,113 @@
+# files/vcs -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Files::Vcs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $VERTICAL_BAR => q{|};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# an OR (|) regex of all vcs files
+has VCS_PATTERNS_ORED => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @vcs_patterns;
+
+ my $COMPRESS_FILE_EXTENSIONS
+ = $self->data->load('files/compressed-file-extensions',qr/\s+/);
+
+ my @quoted_extension_patterns
+ = map { quotemeta } $COMPRESS_FILE_EXTENSIONS->all;
+ my $ored_extension_patterns= ored_patterns(@quoted_extension_patterns);
+
+ my $VCS_CONTROL_PATTERNS
+ = $self->data->load('files/vcs-control-files', qr/\s+/);
+
+ for my $pattern ($VCS_CONTROL_PATTERNS->all) {
+ $pattern =~ s/\$[{]COMPRESS_EXT[}]/(?:$ored_extension_patterns)/g;
+ push(@vcs_patterns, $pattern);
+ }
+
+ my $ored_vcs_patterns = ored_patterns(@vcs_patterns);
+
+ return $ored_vcs_patterns;
+ }
+);
+
+sub ored_patterns {
+ my (@patterns) = @_;
+
+ my @protected = map { "(?:$_)" } @patterns;
+
+ my $ored = join($VERTICAL_BAR, @protected);
+
+ return $ored;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->is_file) {
+
+ my $pattern = $self->VCS_PATTERNS_ORED;
+
+ $self->pointed_hint('package-contains-vcs-control-file',$item->pointer)
+ if $item->name =~ m{$pattern}x
+ && $item->name !~ m{^usr/share/cargo/registry/};
+
+ if ($item->name =~ m/svn-commit.*\.tmp$/) {
+ $self->pointed_hint('svn-commit-file-in-package', $item->pointer);
+ }
+
+ if ($item->name =~ m/svk-commit.+\.tmp$/) {
+ $self->pointed_hint('svk-commit-file-in-package', $item->pointer);
+ }
+
+ } elsif ($item->is_dir) {
+
+ $self->pointed_hint('package-contains-vcs-control-dir', $item->pointer)
+ if $item->name =~ m{/CVS/?$}
+ || $item->name =~ m{/\.(?:svn|bzr|git|hg)/?$}
+ || $item->name =~ m{/\.arch-ids/?$}
+ || $item->name =~ m{/\{arch\}/?$};
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fonts.pm b/lib/Lintian/Check/Fonts.pm
new file mode 100644
index 0000000..edb5c5c
--- /dev/null
+++ b/lib/Lintian/Check/Fonts.pm
@@ -0,0 +1,92 @@
+# fonts -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fonts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->basename
+ =~ m{ [\w-]+ [.] (?:[to]tf | pfb | woff2? | eot) (?:[.]gz)? $}ix;
+
+ my $font = $item->basename;
+
+ my $FONT_PACKAGES = $self->data->fonts;
+
+ my @declared_shippers = $FONT_PACKAGES->installed_by($font);
+
+ if (@declared_shippers) {
+
+ # Fonts in xfonts-tipa are really shipped by tipa.
+ my @renamed
+ = map { $_ eq 'xfonts-tipa' ? 'tipa' : $_ } @declared_shippers;
+
+ my $list
+ = $LEFT_PARENTHESIS
+ . join($SPACE, (sort @renamed))
+ . $RIGHT_PARENTHESIS;
+
+ $self->pointed_hint('duplicate-font-file', $item->pointer, 'also in',
+ $list)
+ unless (any { $_ eq $self->processable->name } @renamed)
+ || $self->processable->type eq 'udeb';
+
+ } else {
+ unless ($item->name =~ m{^usr/lib/R/site-library/}) {
+
+ $self->pointed_hint('font-in-non-font-package', $item->pointer)
+ unless $self->processable->name =~ m/^(?:[ot]tf|t1|x?fonts)-/;
+
+ $self->pointed_hint('font-outside-font-dir', $item->pointer)
+ unless $item->name =~ m{^usr/share/fonts/};
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fonts/Opentype.pm b/lib/Lintian/Check/Fonts/Opentype.pm
new file mode 100644
index 0000000..9ea5dac
--- /dev/null
+++ b/lib/Lintian/Check/Fonts/Opentype.pm
@@ -0,0 +1,95 @@
+# fonts/opentype -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fonts::Opentype;
+
+use v5.20;
+use warnings;
+use utf8;
+use autodie qw(open);
+
+use Const::Fast;
+use Font::TTF::Font;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+const my $COMMA => q{,};
+
+const my $PERMISSIONS_MASK => 0x0f;
+const my $NEVER_EMBED_FLAG => 0x02;
+const my $PRINT_PREVIEW_ONLY_FLAG => 0x04;
+const my $EDIT_ONLY_FLAG => 0x08;
+
+sub visit_installed_files {
+ my ($self, $file) = @_;
+
+ return
+ unless $file->is_file;
+
+ return
+ unless $file->file_type =~ /^OpenType font data/;
+
+ $self->pointed_hint('opentype-font-wrong-filename', $file->pointer)
+ unless $file->name =~ /\.otf$/i;
+
+ my $font = Font::TTF::Font->open($file->unpacked_path);
+
+ my $os2 = defined $font ? $font->{'OS/2'} : undef;
+ my $table = defined $os2 ? $os2->read : undef;
+ my $fs_type = defined $table ? $table->{fsType} : undef;
+
+ $font->release
+ if defined $font;
+
+ return
+ unless defined $fs_type;
+
+ my @clauses;
+
+ my $permissions = $fs_type & $PERMISSIONS_MASK;
+ push(@clauses, 'never embed')
+ if $permissions & $NEVER_EMBED_FLAG;
+ push(@clauses, 'preview/print only')
+ if $permissions & $PRINT_PREVIEW_ONLY_FLAG;
+ push(@clauses, 'edit only')
+ if $permissions & $EDIT_ONLY_FLAG;
+
+ my $terms;
+ $terms = join($COMMA . $SPACE, @clauses)
+ if @clauses;
+
+ $self->pointed_hint('opentype-font-prohibits-installable-embedding',
+ $file->pointer, "($terms)")
+ if length $terms;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fonts/Postscript/Type1.pm b/lib/Lintian/Check/Fonts/Postscript/Type1.pm
new file mode 100644
index 0000000..280eb8f
--- /dev/null
+++ b/lib/Lintian/Check/Fonts/Postscript/Type1.pm
@@ -0,0 +1,130 @@
+# fonts/postscript/type1 -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fonts::Postscript::Type1;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Encode qw(decode);
+use Syntax::Keyword::Try;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+const my $SPACE => q{ };
+const my $COLON => q{:};
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ m/PostScript Type 1 font program data/;
+
+ my @command = ('t1disasm', $item->unpacked_path);
+ my $bytes = safe_qx(@command);
+
+ my $output;
+ try {
+ # iso-8859-1 works too, but the Font 1 standard could be older
+ $output = decode('cp1252', $bytes, Encode::FB_CROAK);
+
+ } catch {
+ die 'In file ' . $item->name . $COLON . $SPACE . $@;
+ }
+
+ my @lines = split(/\n/, $output);
+
+ my $foundadobeline = 0;
+
+ for my $line (@lines) {
+
+ if ($foundadobeline) {
+ if (
+ $line =~ m{\A [%\s]*
+ All\s*Rights\s*Reserved\.?\s*
+ \Z}xsmi
+ ) {
+ $self->pointed_hint(
+ 'license-problem-font-adobe-copyrighted-fragment',
+ $item->pointer);
+
+ last;
+ }
+ }
+
+ $foundadobeline = 1
+ if $line =~ m{\A
+ [%\s]*Copyright\s*\(c\) \s*
+ 19\d{2}[\-\s]19\d{2}\s*
+ Adobe\s*Systems\s*Incorporated\.?\s*\Z}xsmi;
+
+# If copy pasted from black book they are
+# copyright adobe a few line before the only
+# place where the startlock is documented is
+# in the black book copyrighted fragment
+#
+# 2023-06-05: this check has been adjusted because
+# Adobe's type hint code[1] (including Flex[2]) became
+# open source[3] with an Apache-2.0 license[4] as
+# committed on 2014-09-19, making that check a false
+# positive[7].
+#
+# We continue to check for copyrighted code that is not
+# available under an open source license from the origin
+# publication, "Adobe Type 1 Font Format"[5][6].
+#
+# [1] - https://github.com/adobe-type-tools/afdko/blob/2bf85cf44a64148353b24db17e0cc41ede5493b1/FDK/Tools/Programs/public/lib/source/t1write/t1write_hintothers.h
+# [2] - https://github.com/adobe-type-tools/afdko/blob/2bf85cf44a64148353b24db17e0cc41ede5493b1/FDK/Tools/Programs/public/lib/source/t1write/t1write_flexothers.h
+# [3] - https://www.mail-archive.com/debian-bugs-dist@lists.debian.org/msg1375813.html
+# [4] - https://github.com/adobe-type-tools/afdko/blob/2bf85cf44a64148353b24db17e0cc41ede5493b1/LICENSE.txt
+# [5] - https://adobe-type-tools.github.io/font-tech-notes/pdfs/T1_SPEC.pdf
+# [6] - https://lccn.loc.gov/90042516
+# [7] - https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1029555
+ if ($line =~ m/UniqueID\s*6859/) {
+
+ $self->pointed_hint(
+ 'license-problem-font-adobe-copyrighted-fragment-no-credit',
+ $item->pointer);
+
+ last;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Fonts/Truetype.pm b/lib/Lintian/Check/Fonts/Truetype.pm
new file mode 100644
index 0000000..71e120a
--- /dev/null
+++ b/lib/Lintian/Check/Fonts/Truetype.pm
@@ -0,0 +1,95 @@
+# fonts/truetype -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Fonts::Truetype;
+
+use v5.20;
+use warnings;
+use utf8;
+use autodie qw(open);
+
+use Const::Fast;
+use Font::TTF::Font;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+const my $COMMA => q{,};
+
+const my $PERMISSIONS_MASK => 0x0f;
+const my $NEVER_EMBED_FLAG => 0x02;
+const my $PRINT_PREVIEW_ONLY_FLAG => 0x04;
+const my $EDIT_ONLY_FLAG => 0x08;
+
+sub visit_installed_files {
+ my ($self, $file) = @_;
+
+ return
+ unless $file->is_file;
+
+ return
+ unless $file->file_type =~ /^TrueType Font data/;
+
+ $self->pointed_hint('truetype-font-wrong-filename', $file->pointer)
+ unless $file->name =~ /\.ttf$/i;
+
+ my $font = Font::TTF::Font->open($file->unpacked_path);
+
+ my $os2 = defined $font ? $font->{'OS/2'} : undef;
+ my $table = defined $os2 ? $os2->read : undef;
+ my $fs_type = defined $table ? $table->{fsType} : undef;
+
+ $font->release
+ if defined $font;
+
+ return
+ unless defined $fs_type;
+
+ my @clauses;
+
+ my $permissions = $fs_type & $PERMISSIONS_MASK;
+ push(@clauses, 'never embed')
+ if $permissions & $NEVER_EMBED_FLAG;
+ push(@clauses, 'preview/print only')
+ if $permissions & $PRINT_PREVIEW_ONLY_FLAG;
+ push(@clauses, 'edit only')
+ if $permissions & $EDIT_ONLY_FLAG;
+
+ my $terms;
+ $terms = join($COMMA . $SPACE, @clauses)
+ if @clauses;
+
+ $self->pointed_hint('truetype-font-prohibits-installable-embedding',
+ $file->pointer, "($terms)")
+ if length $terms;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/ForeignOperatingSystems.pm b/lib/Lintian/Check/ForeignOperatingSystems.pm
new file mode 100644
index 0000000..7f9fd7d
--- /dev/null
+++ b/lib/Lintian/Check/ForeignOperatingSystems.pm
@@ -0,0 +1,63 @@
+# foreign-operating-systems -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::ForeignOperatingSystems;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # Windows development files
+ $self->pointed_hint('windows-devel-file-in-package', $item->pointer)
+ if $item->name =~ m{/.+\.(?:vcproj|sln|ds[pw])(?:\.gz)?$}
+ && $item->name !~ m{^usr/share/doc/};
+
+ # autogenerated databases from other OSes
+ $self->pointed_hint('windows-thumbnail-database-in-package',$item->pointer)
+ if $item->name =~ m{/Thumbs\.db(?:\.gz)?$}i;
+
+ $self->pointed_hint('macos-ds-store-file-in-package', $item->pointer)
+ if $item->name =~ m{/\.DS_Store(?:\.gz)?$};
+
+ $self->pointed_hint('macos-resource-fork-file-in-package', $item->pointer)
+ if $item->name =~ m{/\._[^_/][^/]*$}
+ && $item->name !~ m/\.swp$/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Games.pm b/lib/Lintian/Check/Games.pm
new file mode 100644
index 0000000..f9ca58a
--- /dev/null
+++ b/lib/Lintian/Check/Games.pm
@@ -0,0 +1,90 @@
+# games -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Games;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # non-games-specific data in games subdirectory
+ if ($item->name=~ m{^usr/share/games/(?:applications|mime|icons|pixmaps)/}
+ && !$item->is_dir) {
+
+ $self->pointed_hint('global-data-in-games-directory', $item->pointer);
+ }
+
+ return;
+}
+
+sub dir_counts {
+ my ($self, $filename) = @_;
+
+ my $item = $self->processable->installed->lookup($filename);
+
+ return 0
+ unless $item;
+
+ return scalar $item->children;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $section = $self->processable->fields->value('Section');
+
+ # section games but nothing in /usr/games
+ # any binary counts to avoid game-data false positives:
+ my $games = $self->dir_counts('usr/games/');
+ my $other = $self->dir_counts('bin/') + $self->dir_counts('usr/bin/');
+
+ if ($other) {
+ if ($section =~ m{games$}) {
+
+ if ($games) {
+ $self->hint('package-section-games-but-has-usr-bin');
+
+ } else {
+ $self->hint('package-section-games-but-contains-no-game');
+ }
+ }
+
+ } elsif ($games > 0 and $section !~ m{games$}) {
+ $self->hint('game-outside-section');
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/GroupChecks.pm b/lib/Lintian/Check/GroupChecks.pm
new file mode 100644
index 0000000..79150a1
--- /dev/null
+++ b/lib/Lintian/Check/GroupChecks.pm
@@ -0,0 +1,282 @@
+# group-checks -- lintian check script -*- perl -*-
+
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::GroupChecks;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $group = $self->group;
+
+ ## To find circular dependencies, we will first generate Strongly
+ ## Connected Components using Tarjan's algorithm
+ ##
+ ## We are not using DepMap, because it cannot tell how the circles
+ ## are made - only that there exists at least 1 circle.
+
+ # The packages a.k.a. nodes
+ my (@nodes, %edges, $sccs);
+ my @installables = grep { $_->type ne 'udeb' } $group->get_installables;
+
+ $self->check_file_overlap(@installables);
+
+ for my $installable (@installables) {
+
+ my $deps = $group->direct_dependencies($installable);
+ if (scalar @{$deps} > 0) {
+ # it depends on another package - it can cause
+ # a circular dependency
+ my $pname = $installable->name;
+ push @nodes, $pname;
+ $edges{$pname} = [map { $_->name } @{$deps}];
+ $self->check_multiarch($installable, $deps);
+ }
+ }
+
+ # Bail now if we do not have at least two packages depending
+ # on some other package from this source.
+ return if scalar @nodes < 2;
+
+ $sccs= Lintian::Check::GroupChecks::Graph->new(\@nodes, \%edges)->tarjans;
+
+ for my $comp (@{$sccs}) {
+ # It takes two to tango... erh. make a circular dependency.
+ next if scalar @{$comp} < 2;
+
+ $self->hint('intra-source-package-circular-dependency',
+ (sort @{$comp}));
+ }
+
+ return;
+}
+
+sub check_file_overlap {
+ my ($self, @processables) = @_;
+
+ # make a local copy to be modified
+ my @remaining = @processables;
+
+ # avoids checking the same combo twice
+ while (@remaining > 1) {
+
+ # avoids checking the same combo twice
+ my $one = shift @remaining;
+
+ my @provides_one = $one->fields->trimmed_list('Provides', qr{,});
+ my $relation_one = Lintian::Relation->new->load(
+ join(' | ', $one->name, @provides_one));
+
+ for my $two (@remaining) {
+
+ # poor man's work-around for "Multi-arch: same"
+ next
+ if $one->name eq $two->name;
+
+ my @provides_two = $two->fields->trimmed_list('Provides', qr{,});
+ my $relation_two = Lintian::Relation->new->load(
+ join(' | ', $two->name, @provides_two));
+
+ # $two conflicts/replaces with $one
+ next
+ if $two->relation('Conflicts')->satisfies($relation_one);
+ next
+ if $two->relation('Replaces')->satisfies($one->name);
+
+ # $one conflicts/replaces with $two
+ next
+ if $one->relation('Conflicts')->satisfies($relation_two);
+ next
+ if $one->relation('Replaces')->satisfies($two->name);
+
+ for my $one_file (@{$one->installed->sorted_list}) {
+
+ my $name = $one_file->name;
+
+ $name =~ s{/$}{};
+ my $two_file = $two->installed->lookup($name)
+ // $two->installed->lookup("$name/");
+ next
+ unless defined $two_file;
+
+ next
+ if $one_file->is_dir && $two_file->is_dir;
+
+ $self->hint('binaries-have-file-conflict',
+ sort($one->name, $two->name), $name);
+ }
+ }
+ }
+
+ return;
+}
+
+sub check_multiarch {
+ my ($self, $processable, $deps) = @_;
+
+ my $KNOWN_DBG_PACKAGE= $self->data->load('common/dbg-pkg',qr/\s*\~\~\s*/);
+
+ my $ma = $processable->fields->value('Multi-Arch') || 'no';
+ if ($ma eq 'same') {
+ for my $dep (@{$deps}) {
+ my $dma = $dep->fields->value('Multi-Arch') || 'no';
+ if ($dma eq 'same' or $dma eq 'foreign') {
+ 1; # OK
+ } else {
+ $self->hint(
+ 'dependency-is-not-multi-archified',
+ join(q{ },
+ $processable->name, 'depends on',
+ $dep->name, "(multi-arch: $dma)")
+ );
+ }
+ }
+ } elsif ($ma ne 'same'
+ and ($processable->fields->value('Section') || 'none')
+ =~ m{(?:^|/)debug$}) {
+ # Debug package that isn't M-A: same, exploit that (non-debug)
+ # dependencies is (almost certainly) a package for which the
+ # debug carries debug symbols.
+ for my $dep (@{$deps}) {
+ my $dma = $dep->fields->value('Multi-Arch') || 'no';
+ if ($dma eq 'same'
+ && ($dep->fields->value('Section') || 'none')
+ !~ m{(?:^|/)debug$}){
+
+ # Debug package isn't M-A: same, but depends on a
+ # package that is from same source that isn't a debug
+ # package and that is M-A same. Thus it is not
+ # possible to install debug symbols for all
+ # (architecture) variants of the binaries.
+ $self->hint(
+ 'debug-package-for-multi-arch-same-pkg-not-coinstallable',
+ $processable->name . ' => ' . $dep->name
+ )
+ unless any { $processable->name =~ m/$_/xms }
+ $KNOWN_DBG_PACKAGE->all;
+ }
+ }
+ }
+ return;
+}
+
+## Encapsulate Tarjan's algorithm in a class/object to keep
+## the run sub somewhat sane. Allow this "extra" package as
+## it is not a proper subclass.
+#<<< no Perl tidy (it breaks the no critic comment)
+package Lintian::Check::GroupChecks::Graph; ## no critic (Modules::ProhibitMultiplePackages)
+#>>>
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+
+sub new {
+ my ($type, $nodes, $edges) = @_;
+ my $self = { nodes => $nodes, edges => $edges};
+ bless $self, $type;
+ return $self;
+}
+
+sub tarjans {
+ my ($self) = @_;
+ my $nodes = $self->{nodes};
+ $self->{index} = 0;
+ $self->{scc} = [];
+ $self->{stack} = [];
+ $self->{on_stack} = {};
+ # The information for each node:
+ # $self->{node_info}{$node}[X], where X is:
+ # 0 => index
+ # 1 => low_index
+ $self->{node_info} = {};
+ for my $node (@{$nodes}) {
+ $self->_tarjans_sc($node)
+ unless defined $self->{node_info}{$node};
+ }
+ return $self->{scc};
+}
+
+sub _tarjans_sc {
+ my ($self, $node) = @_;
+ my $index = $self->{index};
+ my $stack = $self->{stack};
+ my $ninfo = [$index, $index];
+ my $on_stack = $self->{on_stack};
+ $self->{node_info}{$node} = $ninfo;
+ $index++;
+ $self->{index} = $index;
+ push(@{$stack}, $node);
+ $on_stack->{$node} = 1;
+
+ foreach my $neighbour (@{ $self->{edges}{$node} }){
+ my $nb_info;
+ $nb_info = $self->{node_info}{$neighbour};
+ if (!defined $nb_info){
+ # First time visit
+ $self->_tarjans_sc($neighbour);
+ # refresh $nb_info
+ $nb_info = $self->{node_info}{$neighbour};
+ # min($node.low_index, $neigh.low_index)
+ $ninfo->[1] = $nb_info->[1] if $nb_info->[1] < $ninfo->[1];
+ } elsif (exists $on_stack->{$neighbour}) {
+ # Node is in this component
+ # min($node.low_index, $neigh.index)
+ $ninfo->[1] = $nb_info->[0] if $nb_info->[0] < $ninfo->[1];
+ }
+ }
+ if ($ninfo->[0] == $ninfo->[1]){
+ # the "root" node - create the SSC.
+ my $component = [];
+ my $scc = $self->{scc};
+ my $elem = $EMPTY;
+
+ do {
+ $elem = pop @{$stack};
+ delete $on_stack->{$elem};
+ push(@{$component}, $elem);
+
+ } until $node eq $elem;
+
+ push(@{$scc}, $component);
+ }
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/HugeUsrShare.pm b/lib/Lintian/Check/HugeUsrShare.pm
new file mode 100644
index 0000000..0043586
--- /dev/null
+++ b/lib/Lintian/Check/HugeUsrShare.pm
@@ -0,0 +1,98 @@
+# huge-usr-share -- lintian check script -*- perl -*-
+
+# Copyright (C) 2004 Jeroen van Wolffelaar <jeroen@wolffelaar.nl>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::HugeUsrShare;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Threshold in kB of /usr/share to trigger this warning. Consider that the
+# changelog alone can be quite big, and cannot be moved away.
+const my $KIB_SIZE_FACTOR => 1024;
+const my $THRESHOLD_SIZE_SOFT => 4096;
+const my $THRESHOLD_SIZE_HARD => 8192;
+const my $PERCENT => 100;
+const my $THRESHOLD_PERCENTAGE => 50;
+
+has total_size => (is => 'rw', default => 0);
+has usrshare_size => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $file) = @_;
+
+ return
+ unless $file->is_regular_file;
+
+ # space taken up by package
+ $self->total_size($self->total_size + $file->size);
+
+ # space taken up in /usr/share.
+ $self->usrshare_size($self->usrshare_size + $file->size)
+ if $file =~ m{^usr/share/};
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ # skip architecture-dependent packages.
+ my $arch = $self->processable->fields->value('Architecture');
+ return
+ if $arch eq 'all';
+
+ # meaningless; prevents division by zero
+ return
+ if $self->total_size == 0;
+
+ # convert the totals to kilobytes.
+ my $size = sprintf('%.0f', $self->total_size / $KIB_SIZE_FACTOR);
+ my $size_usrshare
+ = sprintf('%.0f', $self->usrshare_size / $KIB_SIZE_FACTOR);
+ my $percentage
+ = sprintf('%.0f', ($self->usrshare_size / $self->total_size) * $PERCENT);
+
+ $self->hint(
+ 'arch-dep-package-has-big-usr-share',
+ "${size_usrshare}kB $percentage%"
+ )
+ if ( $percentage > $THRESHOLD_PERCENTAGE
+ && $size_usrshare > $THRESHOLD_SIZE_SOFT)
+ || $size_usrshare > $THRESHOLD_SIZE_HARD;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Images.pm b/lib/Lintian/Check/Images.pm
new file mode 100644
index 0000000..47021d1
--- /dev/null
+++ b/lib/Lintian/Check/Images.pm
@@ -0,0 +1,49 @@
+# images -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Images;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('image-file-in-usr-lib', $item->pointer)
+ if $item->name =~ m{^usr/lib/}
+ && $item->name =~ m{\.(?:bmp|gif|jpe?g|png|tiff|x[pb]m)$}
+ && !length $item->link;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Images/Filenames.pm b/lib/Lintian/Check/Images/Filenames.pm
new file mode 100644
index 0000000..d728cc6
--- /dev/null
+++ b/lib/Lintian/Check/Images/Filenames.pm
@@ -0,0 +1,126 @@
+# images/filenames -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Images::Filenames;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my @image_formats = (
+ {
+ name => 'PNG',
+ file_type => qr/^PNG image data/,
+ good_name => sub { $_[0] =~ /\.(?:png|PNG)$/ }
+ },
+ {
+ name => 'JPEG',
+ file_type => qr/^JPEG image data/,
+ good_name => sub { $_[0] =~ /\.(?:jpe?g|JPE?G)$/ }
+ },
+ {
+ name => 'GIF',
+ file_type => qr/^GIF image data/,
+ good_name => sub { $_[0] =~ /\.(?:gif|GIF)$/ }
+ },
+ {
+ name => 'TIFF',
+ file_type => qr/^TIFF image data/,
+ good_name => sub { $_[0] =~ /\.(?:tiff?|TIFF?)$/ }
+ },
+ {
+ name => 'XPM',
+ file_type => qr/^X pixmap image/,
+ good_name => sub { $_[0] =~ /\.(?:xpm|XPM)$/ }
+ },
+ {
+ name => 'Netpbm',
+ file_type => qr/^Netpbm image data/,
+ good_name => sub { $_[0] =~ /\.(?:p[bgpn]m|P[BGPN]M)$/ }
+ },
+ {
+ name => 'SVG',
+ file_type => qr/^SVG Scalable Vector Graphics image/,
+ good_name => sub { $_[0] =~ /\.(?:svg|SVG)$/ }
+ },
+);
+
+# ICO format developed into a container and may contain PNG
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ my $our_format;
+
+ for my $format (@image_formats) {
+
+ if ($item->file_type =~ $format->{file_type}) {
+ $our_format = $format;
+ last;
+ }
+ }
+
+ # not an image
+ return
+ unless $our_format;
+
+ return
+ if $our_format->{good_name}->($item->name);
+
+ my $conflicting_format;
+
+ my @other_formats = grep { $_ != $our_format } @image_formats;
+ for my $format (@other_formats) {
+
+ if ($format->{good_name}->($item->name)) {
+ $conflicting_format = $format;
+ last;
+ }
+ }
+
+ if ($conflicting_format) {
+
+ $self->pointed_hint('image-file-has-conflicting-name',
+ $item->pointer, '(is ' . $our_format->{name} . ')')
+ unless $our_format->{good_name}->($item->name);
+
+ } else {
+ $self->pointed_hint('image-file-has-unexpected-name',
+ $item->pointer, '(is ' . $our_format->{name} . ')');
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Images/Thumbnails.pm b/lib/Lintian/Check/Images/Thumbnails.pm
new file mode 100644
index 0000000..c8cc430
--- /dev/null
+++ b/lib/Lintian/Check/Images/Thumbnails.pm
@@ -0,0 +1,56 @@
+# images/thumbnails -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Images::Thumbnails;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ( $item->is_dir
+ && $item->name =~ m{/\.xvpics/?$}) {
+
+ $self->pointed_hint('package-contains-xvpics-dir', $item->pointer);
+ }
+
+ if ( $item->is_dir
+ && $item->name =~ m{/\.thumbnails/?$}) {
+
+ $self->pointed_hint('package-contains-thumbnails-dir', $item->pointer);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Includes/ConfigH.pm b/lib/Lintian/Check/Includes/ConfigH.pm
new file mode 100644
index 0000000..b854a31
--- /dev/null
+++ b/lib/Lintian/Check/Includes/ConfigH.pm
@@ -0,0 +1,56 @@
+# includes/config-h -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Includes::ConfigH;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->name =~ m{^ usr/include/ }x;
+
+ return
+ unless $item->name =~ m{ /config.h $}x;
+
+ $self->hint('package-name-defined-in-config-h', $item->name)
+ if $item->bytes =~ m{ \b PACKAGE_NAME \b }x;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/InitD.pm b/lib/Lintian/Check/InitD.pm
new file mode 100644
index 0000000..304c186
--- /dev/null
+++ b/lib/Lintian/Check/InitD.pm
@@ -0,0 +1,733 @@
+# init.d -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::InitD;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename qw(dirname);
+use List::Compare;
+use List::SomeUtils qw(any none);
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $DOLLAR => q{$};
+
+const my $RUN_LEVEL_6 => 6;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# A list of valid LSB keywords. The value is 0 if optional and 1 if required.
+my %LSB_KEYWORDS = (
+ provides => 1,
+ 'required-start' => 1,
+ 'required-stop' => 1,
+ 'should-start' => 0,
+ 'should-stop' => 0,
+ 'default-start' => 1,
+ 'default-stop' => 1,
+ # These two are actually optional, but we mark
+ # them as required and give them a weaker tag if
+ # they are missing.
+ 'short-description' => 1,
+ 'description' => 1
+);
+
+# These init script names should probably not be used in dependencies.
+# Instead, the corresponding virtual facility should be used.
+#
+# checkroot is not included here since cryptsetup needs the root file system
+# mounted but not any other local file systems and therefore correctly depends
+# on checkroot. There may be other similar situations.
+my %implied_dependencies = (
+ 'mountall' => $DOLLAR . 'local_fs',
+ 'mountnfs' => $DOLLAR . 'remote_fs',
+
+ 'hwclock' => $DOLLAR . 'time',
+ 'portmap' => $DOLLAR . 'portmap',
+ 'named' => $DOLLAR . 'named',
+ 'bind9' => $DOLLAR . 'named',
+ 'networking' => $DOLLAR . 'network',
+ 'syslog' => $DOLLAR . 'syslog',
+ 'rsyslog' => $DOLLAR . 'syslog',
+ 'sysklogd' => $DOLLAR . 'syslog'
+);
+
+# Regex to match names of init.d scripts; it is a bit more lax than
+# package names (e.g. allows "_"). We do not allow it to start with a
+# "dash" to avoid confusing it with a command-line option (also,
+# update-rc.d does not allow this).
+our $INITD_NAME_REGEX = qr/[\w\.\+][\w\-\.\+]*/;
+
+my $OPTS_R = qr/-\S+\s*/;
+my $ACTION_R = qr/\w+/;
+my $EXCLUDE_R = qr/if\s+\[\s+-x\s+\S*update-rc\.d/;
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+
+ my $initd_dir = $processable->installed->resolve_path('etc/init.d/');
+ my $postinst = $processable->control->lookup('postinst');
+ my $preinst = $processable->control->lookup('preinst');
+ my $postrm = $processable->control->lookup('postrm');
+ my $prerm = $processable->control->lookup('prerm');
+
+ my (%initd_postinst, %initd_postrm);
+
+ # These will never be regular initscripts. (see #918459, #933383
+ # and #941140 etc.)
+ return
+ if $pkg eq 'initscripts'
+ || $pkg eq 'sysvinit';
+
+ # read postinst control file
+ if ($postinst and $postinst->is_file and $postinst->is_open_ok) {
+
+ open(my $fd, '<', $postinst->unpacked_path)
+ or die encode_utf8('Cannot open ' . $postinst->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ if $line =~ /$EXCLUDE_R/;
+
+ $line =~ s/\#.*$//;
+
+ next
+ unless $line =~ m{^(?:.+;|^\s*system[\s\(\']+)?\s*update-rc\.d\s+
+ (?:$OPTS_R)*($INITD_NAME_REGEX)\s+($ACTION_R)}x;
+
+ my ($name,$opt) = ($1,$2);
+ next
+ if $opt eq 'remove';
+
+ my $pointer = $postinst->pointer($position);
+
+ if ($initd_postinst{$name}++ == 1) {
+
+ $self->pointed_hint('duplicate-updaterc.d-calls-in-postinst',
+ $pointer, $name);
+ next;
+ }
+
+ $self->pointed_hint(
+ 'output-of-updaterc.d-not-redirected-to-dev-null',
+ $pointer, $name)
+ unless $line =~ m{>\s*/dev/null};
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ # read preinst control file
+ if ($preinst and $preinst->is_file and $preinst->is_open_ok) {
+
+ open(my $fd, '<', $preinst->unpacked_path)
+ or die encode_utf8('Cannot open ' . $preinst->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ if $line =~ /$EXCLUDE_R/;
+
+ $line =~ s/\#.*$//;
+ next
+ unless $line =~ m{update-rc\.d \s+
+ (?:$OPTS_R)*($INITD_NAME_REGEX) \s+
+ ($ACTION_R)}x;
+
+ my $name = $1;
+ my $option = $2;
+ next
+ if $option eq 'remove';
+
+ my $pointer = $preinst->pointer($position);
+
+ $self->pointed_hint('preinst-calls-updaterc.d',
+ $pointer, $name, $option);
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ # read postrm control file
+ if ($postrm and $postrm->is_file and $postrm->is_open_ok) {
+
+ open(my $fd, '<', $postrm->unpacked_path)
+ or die encode_utf8('Cannot open ' . $postrm->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ if $line =~ /$EXCLUDE_R/;
+
+ $line =~ s/\#.*$//;
+
+ next
+ unless $line =~ /update-rc\.d\s+(?:$OPTS_R)*($INITD_NAME_REGEX)/;
+
+ my $name = $1;
+
+ my $pointer = $postrm->pointer($position);
+
+ if ($initd_postrm{$name}++ == 1) {
+
+ $self->pointed_hint('duplicate-updaterc.d-calls-in-postrm',
+ $pointer, $name);
+ next;
+ }
+
+ $self->pointed_hint(
+ 'output-of-updaterc.d-not-redirected-to-dev-null',
+ $pointer, $name)
+ unless $line =~ m{>\s*/dev/null};
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ # read prerm control file
+ if ($prerm and $prerm->is_file and $prerm->is_open_ok) {
+
+ open(my $fd, '<', $prerm->unpacked_path)
+ or die encode_utf8('Cannot open ' . $prerm->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ next
+ if $line =~ /$EXCLUDE_R/;
+
+ $line =~ s/\#.*$//;
+
+ next
+ unless $line =~ /update-rc\.d\s+(?:$OPTS_R)*($INITD_NAME_REGEX)/;
+
+ my $name = $1;
+
+ my $pointer = $prerm->pointer($position);
+
+ $self->pointed_hint('prerm-calls-updaterc.d', $pointer, $name);
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ # init.d scripts have to be removed in postrm
+ for (keys %initd_postinst) {
+ if ($initd_postrm{$_}) {
+ delete $initd_postrm{$_};
+ } else {
+
+ $self->pointed_hint(
+ 'postrm-does-not-call-updaterc.d-for-init.d-script',
+ $postrm->pointer, "etc/init.d/$_");
+ }
+ }
+
+ for (keys %initd_postrm) {
+ $self->pointed_hint('postrm-contains-additional-updaterc.d-calls',
+ $postrm->pointer, "etc/init.d/$_");
+ }
+
+ for my $initd_file (keys %initd_postinst) {
+
+ my $item;
+ $item = $initd_dir->child($initd_file)
+ if $initd_dir;
+
+ unless (
+ (defined $item && $item->resolve_path)
+ ||( defined $item
+ && $item->is_symlink
+ && $item->link eq '/lib/init/upstart-job')
+ ) {
+
+ $self->hint('init.d-script-not-included-in-package',
+ "etc/init.d/$initd_file");
+
+ next;
+ }
+
+ # init.d scripts have to be marked as conffiles unless they're
+ # symlinks.
+ $self->hint('init.d-script-not-marked-as-conffile',
+ "etc/init.d/$initd_file")
+ if !defined $item
+ || ( !$processable->declared_conffiles->is_known($item->name)
+ && !$item->is_symlink);
+
+ # Check if file exists in package and check the script for
+ # other issues if it was included in the package.
+ $self->check_init($item);
+ }
+ $self->check_defaults;
+
+ return
+ unless defined $initd_dir && $initd_dir->is_dir;
+
+ # files actually installed in /etc/init.d should match our list :-)
+ for my $script ($initd_dir->children) {
+
+ next
+ if !$script->is_dir
+ && (any {$script->basename eq $_}qw(README skeleton rc rcS));
+
+ my $tag_name = 'script-in-etc-init.d-not-registered-via-update-rc.d';
+
+ # In an upstart system, such as Ubuntu, init scripts are symlinks to
+ # upstart-job which are not registered with update-rc.d.
+ $tag_name= 'upstart-job-in-etc-init.d-not-registered-via-update-rc.d'
+ if $script->is_symlink
+ && $script->link eq '/lib/init/upstart-job';
+
+ # If $initd_postinst is true for this script, we already
+ # checked the syntax in the above loop. Check the syntax of
+ # unregistered scripts so that we get more complete Lintian
+ # coverage in the first pass.
+ unless ($initd_postinst{$script->basename}) {
+
+ $self->pointed_hint($tag_name, $script->pointer);
+ $self->check_init($script);
+ }
+ }
+
+ return;
+}
+
+sub check_init {
+ my ($self, $item) = @_;
+
+ my $processable = $self->processable;
+
+ # In an upstart system, such as Ubuntu, init scripts are symlinks to
+ # upstart-job. It doesn't make sense to check the syntax of upstart-job,
+ # so skip the checks of the init script itself in that case.
+ return
+ if $item->is_symlink
+ && $item->link eq '/lib/init/upstart-job';
+
+ return
+ unless $item->is_open_ok;
+
+ my %saw_command;
+ my %value_by_lsb_keyword;
+ my $in_file_test = 0;
+ my $needs_fs = 0;
+
+ if ($item->interpreter eq '/lib/init/init-d-script') {
+ $saw_command{$_} = 1 for qw{start stop restart force-reload status};
+ }
+
+ $self->pointed_hint('init.d-script-uses-usr-interpreter',
+ $item->pointer(1), $item->interpreter)
+ if $item->interpreter =~ m{^ /usr/ }x;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ $self->pointed_hint('init.d-script-contains-skeleton-template-content',
+ $item->pointer($position))
+ if $line =~ m{Please remove the "Author" lines|Example initscript};
+
+ if ($line =~ m/^\#\#\# BEGIN INIT INFO/) {
+
+ if (defined $value_by_lsb_keyword{BEGIN}) {
+
+ $self->pointed_hint('init.d-script-has-duplicate-lsb-section',
+ $item->pointer($position));
+ next;
+ }
+
+ $value_by_lsb_keyword{BEGIN} = [1];
+ my $final;
+
+ # We have an LSB keyword section. Parse it and save the data
+ # in %value_by_lsb_keyword for analysis.
+ while (my $other_line = <$fd>) {
+
+ # nested while
+ ++$position;
+
+ if ($other_line =~ /^\#\#\# END INIT INFO/) {
+ $value_by_lsb_keyword{END} = [1];
+ last;
+
+ } elsif ($other_line !~ /^\#/) {
+ $self->pointed_hint(
+ 'init.d-script-has-unterminated-lsb-section',
+ $item->pointer($position));
+ last;
+
+ } elsif ($other_line =~ /^\# ([a-zA-Z-]+):\s*(.*?)\s*$/) {
+
+ my $keyword = lc $1;
+ my $value = $2 // $EMPTY;
+
+ $self->pointed_hint(
+ 'init.d-script-has-duplicate-lsb-keyword',
+ $item->pointer($position), $keyword)
+ if defined $value_by_lsb_keyword{$keyword};
+
+ $self->pointed_hint(
+ 'init.d-script-has-unknown-lsb-keyword',
+ $item->pointer($position), $keyword)
+ unless exists $LSB_KEYWORDS{$keyword}
+ || $keyword =~ /^x-/;
+
+ $value_by_lsb_keyword{$keyword} = [split($SPACE, $value)];
+ $final = $keyword;
+
+ } elsif ($other_line =~ /^\#(\t| )/
+ && $final eq 'description') {
+
+ my $value = $other_line;
+ $value =~ s/^\#\s*//;
+ $value_by_lsb_keyword{description} .= $SPACE . $value;
+
+ } else {
+ $self->pointed_hint('init.d-script-has-bad-lsb-line',
+ $item->pointer($position));
+ }
+ }
+ }
+
+ # Pretty dummy way to handle conditionals, but should be enough
+ # for simple init scripts
+ $in_file_test = 1
+ if $line
+ =~ m{ \b if \s+ .*? (?:test|\[) (?: \s+ \! )? \s+ - [efr] \s+ }x;
+
+ $in_file_test = 0
+ if $line =~ m{ \b fi \b }x;
+
+ if ( !$in_file_test
+ && $line =~ m{^\s*\.\s+["'"]?(/etc/default/[\$\w/-]+)}){
+ my $sourced = $1;
+
+ $self->pointed_hint('init.d-script-sourcing-without-test',
+ $item->pointer($position), $sourced);
+ }
+
+ # Some init.d scripts source init-d-script, since (e.g.)
+ # kFreeBSD does not allow shell scripts as interpreters.
+ if ($line =~ m{\. /lib/init/init-d-script}) {
+ $saw_command{$_} = 1
+ for qw{start stop restart force-reload status};
+ }
+
+ # This should be more sophisticated: ignore heredocs, ignore quoted
+ # text and the arguments to echo, etc.
+ $needs_fs = 1
+ if $line =~ m{^[^\#]*/var/};
+
+ while ($line =~ s/^[^\#]*?(start|stop|restart|force-reload|status)//) {
+ $saw_command{$1} = 1;
+ }
+
+ # nested while
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ # Make sure all of the required keywords are present.
+ if (!defined $value_by_lsb_keyword{BEGIN}) {
+ $self->pointed_hint('init.d-script-missing-lsb-section',
+ $item->pointer);
+
+ } else {
+ for my $keyword (keys %LSB_KEYWORDS) {
+
+ if ($LSB_KEYWORDS{$keyword}
+ && !defined $value_by_lsb_keyword{$keyword}) {
+
+ if ($keyword eq 'short-description') {
+ $self->pointed_hint(
+ 'init.d-script-missing-lsb-short-description',
+ $item->pointer);
+
+ } elsif ($keyword eq 'description') {
+ next;
+
+ } else {
+ $self->pointed_hint('init.d-script-missing-lsb-keyword',
+ $item->pointer, $keyword);
+ }
+ }
+ }
+ }
+
+ # Check the runlevels.
+ my %start;
+
+ for my $runlevel (@{$value_by_lsb_keyword{'default-start'} // []}) {
+
+ if ($runlevel =~ /^[sS0-6]$/) {
+
+ $start{lc $runlevel} = 1;
+
+ $self->pointed_hint('init.d-script-starts-in-stop-runlevel',
+ $item->pointer, $runlevel)
+ if $runlevel eq '0'
+ || $runlevel eq '6';
+
+ } else {
+ $self->pointed_hint('init.d-script-has-bad-start-runlevel',
+ $item->pointer, $runlevel);
+ }
+ }
+
+ # No script should start at one of the 2-5 runlevels but not at
+ # all of them
+ my $start = join($SPACE, (sort grep { /^[2-5]$/ } keys %start));
+
+ if (length($start) > 0 and $start ne '2 3 4 5') {
+ my @missing = grep { !exists $start{$_} } qw(2 3 4 5);
+
+ $self->pointed_hint('init.d-script-missing-start', $item->pointer,
+ @missing);
+ }
+
+ my %stop;
+
+ for my $runlevel (@{$value_by_lsb_keyword{'default-stop'} // []}) {
+
+ if ($runlevel =~ /^[sS0-6]$/) {
+
+ $stop{$runlevel} = 1
+ unless $runlevel =~ /[sS2-5]/;
+
+ $self->pointed_hint('init.d-script-has-conflicting-start-stop',
+ $item->pointer, $runlevel)
+ if exists $start{$runlevel};
+
+ $self->pointed_hint('init-d-script-stops-in-s-runlevel',
+ $item->pointer)
+ if $runlevel =~ /[sS]/;
+
+ } else {
+ $self->pointed_hint('init.d-script-has-bad-stop-runlevel',
+ $item->pointer, $runlevel);
+ }
+ }
+
+ if (none { $item->basename eq $_ } qw(killprocs sendsigs halt reboot)) {
+
+ my @required = (0, 1, $RUN_LEVEL_6);
+ my $stop_lc = List::Compare->new(\@required, [keys %stop]);
+
+ my @have_some = $stop_lc->get_intersection;
+ my @missing = $stop_lc->get_Lonly;
+
+ # Scripts that stop in any of 0, 1, or 6 probably should stop in all
+ # of them, with some special exceptions.
+ $self->pointed_hint('init.d-script-possible-missing-stop',
+ $item->pointer, (sort @missing))
+ if @have_some
+ && @missing
+ && (%start != 1 || !exists $start{s});
+ }
+
+ my $provides_self = 0;
+ for my $facility (@{$value_by_lsb_keyword{'provides'} // []}) {
+
+ $self->pointed_hint('init.d-script-provides-virtual-facility',
+ $item->pointer, $facility)
+ if $facility =~ /^\$/;
+
+ $provides_self = 1
+ if $item->basename =~/^\Q$facility\E(?:.sh)?$/;
+ }
+
+ $self->pointed_hint('init.d-script-does-not-provide-itself',$item->pointer)
+ if defined $value_by_lsb_keyword{'provides'}
+ && !$provides_self;
+
+ # Separately check Required-Start and Required-Stop, since while they're
+ # similar, they're not quite identical. This could use some further
+ # restructuring by pulling the regexes out as data tied to start/stop and
+ # remote/local and then combining the loops.
+ if (@{$value_by_lsb_keyword{'default-start'} // []}) {
+
+ my @required = @{$value_by_lsb_keyword{'required-start'} // []};
+
+ if ($needs_fs) {
+ if (none { /^\$(?:local_fs|remote_fs|all)\z/ } @required) {
+
+ $self->pointed_hint(
+ 'init.d-script-missing-dependency-on-local_fs',
+ $item->pointer, 'required-start');
+ }
+ }
+ }
+
+ if (@{$value_by_lsb_keyword{'default-stop'} // []}) {
+
+ my @required = @{$value_by_lsb_keyword{'required-stop'} // []};
+
+ if ($needs_fs) {
+ if (none { /^(?:\$(?:local|remote)_fs|\$all|umountn?fs)\z/ }
+ @required) {
+
+ $self->pointed_hint(
+ 'init.d-script-missing-dependency-on-local_fs',
+ $item->pointer, 'required-stop');
+ }
+ }
+ }
+
+ my $VIRTUAL_FACILITIES= $self->data->virtual_initd_facilities;
+
+ # Check syntax rules that apply to all of the keywords.
+ for
+ my $keyword (qw(required-start should-start required-stop should-stop)){
+ for my $prerequisite (@{$value_by_lsb_keyword{$keyword} // []}) {
+
+ if (exists $implied_dependencies{$prerequisite}) {
+
+ $self->pointed_hint('non-virtual-facility-in-initd-script',
+ $item->pointer,
+ "$prerequisite -> $implied_dependencies{$prerequisite}");
+
+ } elsif ($keyword =~ m/^required-/ && $prerequisite =~ m/^\$/) {
+
+ $self->pointed_hint(
+ 'init.d-script-depends-on-unknown-virtual-facility',
+ $item->pointer, $prerequisite)
+ unless ($VIRTUAL_FACILITIES->recognizes($prerequisite));
+ }
+
+ $self->pointed_hint(
+ 'init.d-script-depends-on-all-virtual-facility',
+ $item->pointer, $keyword)
+ if $prerequisite =~ m/^\$all$/;
+ }
+ }
+
+ my @required_commands = qw{start stop restart force-reload};
+ my $command_lc
+ = List::Compare->new(\@required_commands, [keys %saw_command]);
+ my @missing_commands = $command_lc->get_Lonly;
+
+ # all tags included in file?
+ $self->pointed_hint('init.d-script-does-not-implement-required-option',
+ $item->pointer, $_)
+ for @missing_commands;
+
+ $self->pointed_hint('init.d-script-does-not-implement-status-option',
+ $item->pointer)
+ unless $saw_command{'status'};
+
+ return;
+}
+
+sub check_defaults {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ my $dir = $processable->installed->resolve_path('etc/default/');
+ return
+ unless $dir && $dir->is_dir;
+
+ for my $item ($dir->children) {
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ $self->pointed_hint('init.d-script-should-always-start-service',
+ $item->pointer($position))
+ if $line
+ =~ m{^ \s* [#]* \s* (?:[A-Z]_)? (?:ENABLED|DISABLED|[A-Z]*RUN | (?:NO_)? START) = }x;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item =~ m{etc/sv/([^/]+)/$}) {
+
+ my $service = $1;
+ my $runfile
+ = $self->processable->installed->resolve_path(
+ "etc/sv/${service}/run");
+
+ $self->pointed_hint(
+ 'directory-in-etc-sv-directory-without-executable-run-script',
+ $item->pointer, $runfile)
+ unless defined $runfile && $runfile->is_executable;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/InitD/MaintainerScript.pm b/lib/Lintian/Check/InitD/MaintainerScript.pm
new file mode 100644
index 0000000..b44d103
--- /dev/null
+++ b/lib/Lintian/Check/InitD/MaintainerScript.pm
@@ -0,0 +1,147 @@
+# init-d/maintainer-script -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::InitD::MaintainerScript;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $saw_init = 0;
+ my $saw_invoke = 0;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+ # Collect information about init script invocations to
+ # catch running init scripts directly rather than through
+ # invoke-rc.d. Since the script is allowed to run the
+ # init script directly if invoke-rc.d doesn't exist, only
+ # tag direct invocations where invoke-rc.d is never used
+ # in the same script. Lots of false negatives, but
+ # hopefully not many false positives.
+ $saw_init = $position
+ if $line =~ m{^\s*/etc/init\.d/(?:\S+)\s+[\"\']?(?:\S+)[\"\']?};
+
+ $saw_invoke = $position
+ if $line =~ m{^\s*invoke-rc\.d\s+};
+
+ } continue {
+ ++$position;
+ }
+
+ if ($saw_init && !$saw_invoke) {
+
+ my $pointer = $item->pointer($saw_init);
+
+ $self->pointed_hint('maintainer-script-calls-init-script-directly',
+ $pointer);
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Fortran/Gfortran.pm b/lib/Lintian/Check/Languages/Fortran/Gfortran.pm
new file mode 100644
index 0000000..6479d8a
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Fortran/Gfortran.pm
@@ -0,0 +1,94 @@
+# languages/fortran/gfortran -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Fortran::Gfortran;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $NEWLINE => qq{\n};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # file-info would be great, but files are zipped
+ return
+ unless $item->name =~ m{\.mod$};
+
+ return
+ unless $item->name =~ m{^usr/lib/};
+
+ # do not look at flang, grub or libreoffice modules
+ return
+ if $item->name =~ m{/flang-\d+/}
+ || $item->name =~ m{^usr/lib/grub}
+ || $item->name =~ m{^usr/lib/libreoffice};
+
+ return
+ unless $item->is_file
+ && $item->is_open_ok
+ && $item->file_type =~ /\bgzip compressed\b/;
+
+ my $module_version;
+
+ open(my $fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8(
+ 'Cannot open gz file ' . $item->unpacked_path . $NEWLINE);
+
+ while (my $line = <$fd>) {
+ next
+ if $line =~ /^\s*$/;
+
+ ($module_version) = ($line =~ /^GFORTRAN module version '(\d+)'/);
+ last;
+ }
+
+ close $fd;
+
+ unless (length $module_version) {
+ $self->pointed_hint('gfortran-module-does-not-declare-version',
+ $item->pointer);
+ return;
+ }
+
+ my $depends = $self->processable->fields->value('Depends');
+ $self->pointed_hint('missing-prerequisite-for-gfortran-module',
+ $item->pointer)
+ unless $depends =~ /\bgfortran-mod-$module_version\b/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Golang/BuiltUsing.pm b/lib/Lintian/Check/Languages/Golang/BuiltUsing.pm
new file mode 100644
index 0000000..79095d3
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Golang/BuiltUsing.pm
@@ -0,0 +1,68 @@
+# languages/golang/built-using -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Golang::BuiltUsing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->relation('Build-Depends')
+ ->satisfies('golang-go | golang-any');
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+ my $installable_fields= $control->installable_fields($installable);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position('Package');
+
+ $self->pointed_hint(
+ 'missing-built-using-field-for-golang-package',
+ $control_item->pointer($position),
+ "(in section for $installable)"
+ )
+ if $installable_fields->value('Built-Using')
+ !~ m{ \$ [{] misc:Built-Using [}] }x
+ && $installable_fields->value('Architecture') ne 'all';
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Golang/ImportPath.pm b/lib/Lintian/Check/Languages/Golang/ImportPath.pm
new file mode 100644
index 0000000..210696b
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Golang/ImportPath.pm
@@ -0,0 +1,56 @@
+# languages/golang/import-path -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Golang::ImportPath;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ return
+ unless $self->processable->relation('Build-Depends')
+ ->satisfies('golang-go | golang-any');
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ $self->hint('missing-xs-go-import-path-for-golang-package')
+ unless $source_fields->declares('XS-Go-Import-Path');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Java.pm b/lib/Lintian/Check/Languages/Java.pm
new file mode 100644
index 0000000..4b26512
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Java.pm
@@ -0,0 +1,315 @@
+# languages/java -- lintian check script -*- perl -*-
+
+# Copyright (C) 2011 Vincent Fourmond
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Java;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::SomeUtils qw(any none);
+
+use Lintian::Util qw(normalize_link_target $PKGNAME_REGEX $PKGVERSION_REGEX);
+
+const my $EMPTY => q{};
+const my $HYPHEN => q{-};
+
+const my $ARROW => q{->};
+
+const my $BYTE_CODE_VERSION_OFFSET => 44;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+our $CLASS_REGEX = qr/\.(?:class|cljc?)/;
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ my $java_info = $item->java_info;
+ return
+ unless scalar keys %{$java_info};
+
+ my $files = $java_info->{files};
+
+ $self->pointed_hint('source-contains-prebuilt-java-object', $item->pointer)
+ if any { m/$CLASS_REGEX$/i } keys %{$files};
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $missing_jarwrapper = 0;
+ my $has_public_jars = 0;
+ my $jmajlow = $HYPHEN;
+
+ my $depends = $self->processable->relation('strong')->to_string;
+
+ # Remove all libX-java-doc packages to avoid thinking they are java libs
+ # - note the result may not be a valid dependency listing
+ $depends =~ s/lib[^\s,]+-java-doc//g;
+
+ my @java_lib_depends = ($depends =~ m/\b(lib[^\s,]+-java)\b/g);
+
+ my $JAVA_BYTECODES= $self->data->load('java/constants', qr/\s*=\s*/);
+
+ # We first loop over jar files to find problems
+
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ my $java_info = $item->java_info;
+ next
+ unless scalar keys %{$java_info};
+
+ my $files = $java_info->{files};
+ my $manifest = $java_info->{manifest};
+ my $jar_dir = dirname($item->name);
+ my $classes = 0;
+ my $datafiles = 1;
+ my $class_path = $EMPTY;
+ my $bsname = $EMPTY;
+
+ if (exists $java_info->{error}) {
+ $self->pointed_hint('zip-parse-error', $item->pointer,
+ $java_info->{error});
+ next;
+ }
+
+ # The Java Policy says very little about requires for (jars in) JVMs
+ next
+ if $item->name =~ m{^usr/lib/jvm(?:-exports)?/[^/]+/};
+
+ # Ignore Mozilla's jar files, see #635495
+ next
+ if $item->name =~ m{^usr/lib/xul(?:-ext|runner[^/]*+)/};
+
+ if ($item->name =~ m{^usr/share/java/[^/]+\.jar$}) {
+ $has_public_jars = 1;
+
+ # java policy requires package version too; see Bug#976681
+ $self->pointed_hint('bad-jar-name', $item->pointer)
+ unless basename($item->name)
+ =~ /^$PKGNAME_REGEX-$PKGVERSION_REGEX\.jar$/;
+ }
+
+ # check for common code files like .class or .clj (Clojure files)
+ for my $class (grep { m/$CLASS_REGEX$/i } sort keys %{$files}){
+
+ my $module_version = $files->{$class};
+ (my $src = $class) =~ s/\.[^.]+$/\.java/;
+
+ $self->pointed_hint('jar-contains-source', $item->pointer, $src)
+ if %{$files}{$src};
+
+ $classes = 1;
+
+ next
+ if $class =~ m/\.cljc?$/;
+
+ # .class but no major version?
+ next
+ if $module_version eq $HYPHEN;
+
+ if ($module_version
+ < $JAVA_BYTECODES->value('lowest-known-bytecode-version')
+ || $module_version
+ > $JAVA_BYTECODES->value('highest-known-bytecode-version')) {
+
+ # First public major version was 45 (Java1), latest
+ # version is 55 (Java11).
+ $self->pointed_hint('unknown-java-class-version',
+ $item->pointer,$class, $ARROW, $module_version);
+
+ # Skip the rest of this Jar.
+ last;
+ }
+
+ # Collect the "lowest" Class version used. We assume that
+ # mixed class formats implies special compat code for certain
+ # JVM cases.
+ if ($jmajlow eq $HYPHEN) {
+ # first;
+ $jmajlow = $module_version;
+
+ } else {
+ $jmajlow = $module_version
+ if $module_version < $jmajlow;
+ }
+ }
+
+ $datafiles = 0
+ if none { /\.(?:xml|properties|x?html|xhp)$/i } keys %{$files};
+
+ if ($item->is_executable) {
+
+ $self->pointed_hint('executable-jar-without-main-class',
+ $item->pointer)
+ unless $manifest && $manifest->{'Main-Class'};
+
+ # Here, we need to check that the package depends on
+ # jarwrapper.
+ $missing_jarwrapper = 1
+ unless $self->processable->relation('strong')
+ ->satisfies('jarwrapper');
+
+ } elsif ($item->name !~ m{^usr/share/}) {
+
+ $self->pointed_hint('jar-not-in-usr-share', $item->pointer);
+ }
+
+ $class_path = $manifest->{'Class-Path'}//$EMPTY if $manifest;
+ $bsname = $manifest->{'Bundle-SymbolicName'}//$EMPTY if $manifest;
+
+ if ($manifest) {
+ if (!$classes) {
+
+ # Eclipse / OSGi bundles are sometimes source bundles
+ # these do not ship classes but java files and other sources.
+ # Javadoc jars deployed in the Maven repository also do not ship
+ # classes but HTML files, images and CSS files
+ if (
+ (
+ $bsname !~ m/\.source$/
+ && $item->name
+ !~ m{^usr/share/maven-repo/.*-javadoc\.jar}
+ && $item->name !~ m{\.doc(?:\.(?:user|isv))?_[^/]+.jar}
+ && $item->name !~ m{\.source_[^/]+.jar}
+ )
+ || $class_path
+ ) {
+ $self->pointed_hint('codeless-jar', $item->pointer);
+ }
+ }
+
+ } elsif ($classes) {
+ $self->pointed_hint('missing-manifest', $item->pointer);
+ }
+
+ if ($class_path) {
+ # Only run the tests when a classpath is present
+ my @relative;
+ my @paths = split(m/\s++/, $class_path);
+ for my $p (@paths) {
+ if ($p) {
+ # Strip leading ./
+ $p =~ s{^\./+}{}g;
+ if ($p !~ m{^(?:file://)?/} && $p =~ m{/}) {
+ my $target = normalize_link_target($jar_dir, $p);
+ my $tinfo;
+ # Can it be normalized?
+ next unless defined($target);
+ # Relative link to usr/share/java ? Works if
+ # we are depending of a Java library.
+ next
+ if $target =~ m{^usr/share/java/[^/]+.jar$}
+ && @java_lib_depends;
+ $tinfo= $self->processable->installed->lookup($target);
+ # Points to file or link in this package,
+ # which is sometimes easier than
+ # re-writing the classpath.
+ next
+ if defined $tinfo
+ and ($tinfo->is_symlink or $tinfo->is_file);
+ # Relative path with subdirectories.
+ push @relative, $p;
+ }
+ # @todo add an info tag for relative paths, to educate
+ # maintainers ?
+ }
+ }
+
+ $self->pointed_hint('classpath-contains-relative-path',
+ $item->pointer, join(', ', @relative))
+ if @relative;
+ }
+
+ # Trigger a warning when a maven plugin lib is installed in
+ # /usr/share/java/
+ $self->pointed_hint('maven-plugin-in-usr-share-java', $item->pointer)
+ if $has_public_jars
+ && $self->processable->name =~ /^lib.*maven.*plugin.*/
+ && $item->name !~ m{^usr/share/maven-repo/.*\.jar};
+ }
+
+ $self->hint('missing-dep-on-jarwrapper') if $missing_jarwrapper;
+
+ if ($jmajlow ne $HYPHEN) {
+ # Byte code numbers:
+ # 45-49 -> Java1 - Java5 (Always ok)
+ # 50 -> Java6
+ # 51 -> Java7
+ # 52 -> Java8
+ # 53 -> Java9
+ # 54 -> Java10
+ # 55 -> Java11
+ my $bad = 0;
+
+ # If the lowest version used is greater than the requested
+ # limit, then flag it.
+ $bad = 1
+ if $jmajlow > $JAVA_BYTECODES->value('default-bytecode-version');
+
+ # Technically we ought to do some checks with Java6 class
+ # files and dependencies/package types, but for now just skip
+ # that. (See #673276)
+
+ if ($bad) {
+ # Map the Class version to a Java version.
+ my $java_version = $jmajlow - $BYTE_CODE_VERSION_OFFSET;
+
+ $self->hint('incompatible-java-bytecode-format',
+ "Java$java_version version (Class format: $jmajlow)");
+ }
+ }
+
+ if ( !$has_public_jars
+ && !$self->processable->is_transitional
+ && $self->processable->name =~ /^lib[^\s,]+-java$/){
+
+ # Skip this if it installs a symlink in usr/share/java
+ my $java_dir
+ = $self->processable->installed->resolve_path('usr/share/java/');
+
+ my $has_jars = 0;
+ $has_jars = 1
+ if $java_dir
+ && (any { $_->name =~ m{^[^/]+\.jar$} } $java_dir->children);
+
+ $self->hint('javalib-but-no-public-jars')
+ unless $has_jars;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Java/Bytecode.pm b/lib/Lintian/Check/Languages/Java/Bytecode.pm
new file mode 100644
index 0000000..14566a9
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Java/Bytecode.pm
@@ -0,0 +1,58 @@
+# languages/java/bytecode -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Java::Bytecode;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $MAGIC_BYTE_SIZE => 4;
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # .class (compiled Java files)
+ if ( $item->name =~ /\.class$/
+ && $item->name !~ /(?:WEB-INF|demo|doc|example|sample|test)/) {
+
+ my $magic = $item->magic($MAGIC_BYTE_SIZE);
+
+ $self->pointed_hint('package-installs-java-bytecode', $item->pointer)
+ if $magic eq "\xCA\xFE\xBA\xBE";
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Javascript/Embedded.pm b/lib/Lintian/Check/Languages/Javascript/Embedded.pm
new file mode 100644
index 0000000..9227187
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Javascript/Embedded.pm
@@ -0,0 +1,149 @@
+# languages/javascript/embedded -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Javascript::Embedded;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my %JS_MAGIC
+ = ('libjs-bootstrap' => qr{ var [ ] (?: Carousel | Typeahead ) }x,);
+
+my $JS_EXT
+ = qr{(?:(?i)[-._]?(?:compiled|lite|min|pack(?:ed)?|prod|umd|yc)?\.(js|css)(?:\.gz)?)$};
+my %JS_FILES = (
+ 'ckeditor' => qr{(?i)/ckeditor} . $JS_EXT,
+ 'fckeditor' => qr{(?i)/fckeditor} . $JS_EXT,
+ 'libjs-async' => qr{(?i)/async} . $JS_EXT,
+ 'libjs-bootstrap' => qr{(?i)/bootstrap(?:-[\d\.]+)?} . $JS_EXT,
+ 'libjs-chai' => qr{(?i)/chai} . $JS_EXT,
+ 'libjs-cropper' => qr{(?i)/cropper(?:\.uncompressed)?} . $JS_EXT,
+ 'libjs-dojo-\w+' => qr{(?i)/(?:dojo|dijit)} . $JS_EXT,
+ 'libjs-excanvas' => qr{(?i)/excanvas(?:-r[0-9]+)?} . $JS_EXT,
+ 'libjs-jac' => qr{(?i)/jsjac} . $JS_EXT,
+ 'libjs-jquery' => qr{(?i)/jquery(?:-[\d\.]+)?} . $JS_EXT,
+ 'libjs-jquery-cookie' => qr{(?i)/jquery\.cookie} . $JS_EXT,
+ 'libjs-jquery-easing' => qr{(?i)/jquery\.easing} . $JS_EXT,
+ 'libjs-jquery-event-drag' => qr{(?i)/jquery\.event\.drap} . $JS_EXT,
+ 'libjs-jquery-event-drop' => qr{(?i)/jquery\.event\.drop} . $JS_EXT,
+ 'libjs-jquery-fancybox' => qr{(?i)/jquery\.fancybox} . $JS_EXT,
+ 'libjs-jquery-form' => qr{(?i)/jquery\.form} . $JS_EXT,
+ 'libjs-jquery-galleriffic' => qr{(?i)/jquery\.galleriffic} . $JS_EXT,
+ 'libjs-jquery-history' => qr{(?i)/jquery\.history} . $JS_EXT,
+ 'libjs-jquery-jfeed' => qr{(?i)/jquery\.jfeed} . $JS_EXT,
+ 'libjs-jquery-jush' => qr{(?i)/jquery\.jush} . $JS_EXT,
+ 'libjs-jquery-livequery' => qr{(?i)/jquery\.livequery} . $JS_EXT,
+ 'libjs-jquery-meiomask' => qr{(?i)/jquery\.meiomask} . $JS_EXT,
+ 'libjs-jquery-metadata' => qr{(?i)/jquery\.metadata} . $JS_EXT,
+ 'libjs-jquery-migrate-1' => qr{(?i)/jquery-migrate(?:-1[\d\.]*)}
+ . $JS_EXT,
+ 'libjs-jquery-mousewheel' => qr{(?i)/jquery\.mousewheel} . $JS_EXT,
+ 'libjs-jquery-opacityrollover' => qr{(?i)/jquery\.opacityrollover}
+ . $JS_EXT,
+ 'libjs-jquery-tablesorter' => qr{(?i)/jquery\.tablesorter} . $JS_EXT,
+ 'libjs-jquery-tipsy' => qr{(?i)/jquery\.tipsy} . $JS_EXT,
+ 'libjs-jquery-treetable' => qr{(?i)/jquery\.treetable} . $JS_EXT,
+ 'libjs-jquery-ui' => qr{(?i)/jquery[\.-](?:-[\d\.]+)?ui}
+ . $JS_EXT,
+ 'libjs-mocha' => qr{(?i)/mocha} . $JS_EXT,
+ 'libjs-mochikit' => qr{(?i)/mochikit} . $JS_EXT,
+ 'libjs-mootools' =>
+qr{(?i)/mootools(?:(?:\.v|-)[\d\.]+)?(?:-(?:(?:core(?:-server)?)|more)(?:-(?:yc|jm|nc))?)?}
+ . $JS_EXT,
+ 'libjs-mustache' => qr{(?i)/mustache} . $JS_EXT,
+# libjs-normalize is provided by node-normalize.css but this is an implementation detail
+ 'libjs-normalize' => qr{(?i)/normalize(?:\.min)?\.css},
+ 'libjs-prototype' => qr{(?i)/prototype(?:-[\d\.]+)?}. $JS_EXT,
+ 'libjs-raphael' => qr{(?i)/raphael(?:[\.-]min)?} . $JS_EXT,
+ 'libjs-scriptaculous' => qr{(?i)/scriptaculous} . $JS_EXT,
+ 'libjs-strophe' => qr{(?i)/strophe} . $JS_EXT,
+ 'libjs-underscore' => qr{(?i)/underscore} . $JS_EXT,
+ 'libjs-yui' => qr{(?i)/(?:yahoo|yui)-(?:dom-event)?}
+ . $JS_EXT,
+ # Disabled due to false positives. Needs a content check adding to verify
+ # that the file being checked is /the/ yahoo.js
+ # 'libjs-yui' => qr{(?i)/yahoo\.js(\.gz)?} . $JS_EXT,
+ 'jsmath' => qr{(?i)/jsMath(?:-fallback-\w+)?}
+ . $JS_EXT,
+ 'node-html5shiv' => qr{(?i)html5shiv(?:-printshiv)?}
+ . $JS_EXT,
+ 'sphinx' =>
+ qr{(?i)/_static/(?:doctools|language_data|searchtools)} . $JS_EXT,
+ 'tinymce' => qr{(?i)/tiny_mce(?:_(?:popup|src))?}
+ . $JS_EXT,
+ 'libjs-lodash' => qr{(?i)lodash} . $JS_EXT,
+ 'node-pako' =>
+ qr{(?i)pako(?:_(:?de|in)flate(?:.es\d+)?)(?:-[\d\.]+)?}. $JS_EXT,
+ 'node-jszip-utils' => qr{(?i)jszip-utils(?:-ie)?(?:-[\d\.]+)?}
+ . $JS_EXT,
+ 'node-jszip' => qr{(?i)jszip(?:-ie)?(?:-[\d\.]+)?} . $JS_EXT,
+ 'libjs-codemirror' => qr{(?i)codemirror} . $JS_EXT,
+ 'libjs-punycode' => qr{(?i)punycode(?:\.es\d+)?} . $JS_EXT,
+# not yet available in unstable
+# 'xinha' => qr{(?i)/(htmlarea|Xinha(Loader|Core))} . $JS_EXT,
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # ignore embedded jQuery libraries for Doxygen (#736360)
+ my $doxygen = $self->processable->installed->resolve_path(
+ $item->dirname . 'doxygen.css');
+ return
+ if $item->basename eq 'jquery.js'
+ && defined $doxygen;
+
+ # embedded javascript
+ for my $provider (keys %JS_FILES) {
+
+ next
+ if $self->processable->name =~ /^$provider$/;
+
+ next
+ unless $item->name =~ /$JS_FILES{$provider}/;
+
+ next
+ if length $JS_MAGIC{$provider}
+ && !length $item->bytes_match($JS_MAGIC{$provider});
+
+ $self->pointed_hint('embedded-javascript-library', $item->pointer,
+ 'please use', $provider);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Javascript/Nodejs.pm b/lib/Lintian/Check/Languages/Javascript/Nodejs.pm
new file mode 100644
index 0000000..98a5d76
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Javascript/Nodejs.pm
@@ -0,0 +1,262 @@
+# languages/javascript/nodejs -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019-2020, Xavier Guimard <yadd@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Javascript::Nodejs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use JSON::MaybeXS;
+use List::SomeUtils qw(any none first_value);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation;
+
+const my $SLASH => q{/};
+const my $DOT => q{.};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+
+ # debian/control check
+ my @testsuites
+ = split(m/\s*,\s*/,$debian_control->source_fields->value('Testsuite'));
+
+ if (any { $_ eq 'autopkgtest-pkg-nodejs' } @testsuites) {
+
+ my $item = $self->processable->patched->resolve_path(
+ 'debian/tests/pkg-js/test');
+ if (defined $item) {
+
+ $self->pointed_hint('pkg-js-autopkgtest-test-is-empty',
+ $item->pointer)
+ if none { /^[^#]*\w/m } $item->bytes;
+
+ } else {
+ $self->hint('pkg-js-autopkgtest-test-is-missing');
+ }
+
+ # Ensure all files referenced in debian/tests/pkg-js/files exist
+ my $files
+ = $self->processable->patched->resolve_path(
+ 'debian/tests/pkg-js/files');
+ if (defined $files) {
+
+ my @patterns = path($files->unpacked_path)->lines;
+
+ # trim leading and trailing whitespace
+ s/^\s+|\s+$//g for @patterns;
+
+ my @notfound = grep { !$self->path_exists($_) } @patterns;
+
+ $self->hint('pkg-js-autopkgtest-file-does-not-exist', $_)
+ for @notfound;
+ }
+ }
+
+ # debian/rules check
+ my $droot = $self->processable->patched->resolve_path('debian/')
+ or return;
+ my $drules = $droot->child('rules')
+ or return;
+
+ return
+ unless $drules->is_open_ok;
+
+ open(my $rules_fd, '<', $drules->unpacked_path)
+ or die encode_utf8('Cannot open ' . $drules->unpacked_path);
+
+ my $command_prefix_pattern = qr/\s+[@+-]?(?:\S+=\S+\s+)*/;
+ my ($seen_nodejs,$override_test,$seen_dh_dynamic);
+ my $bdepends = $self->processable->relation('Build-Depends-All');
+ $seen_nodejs = 1 if $bdepends->satisfies('dh-sequence-nodejs');
+
+ while (my $line = <$rules_fd>) {
+
+ # reconstitute splitted lines
+ while ($line =~ s/\\$// && defined(my $cont = <$rules_fd>)) {
+ $line .= $cont;
+ }
+
+ # skip comments
+ next
+ if $line =~ /^\s*\#/;
+
+ if ($line =~ m{^(?:$command_prefix_pattern)dh\s+}) {
+ $seen_dh_dynamic = 1
+ if $line =~ /\$[({]\w/;
+
+ while ($line =~ /\s--with(?:=|\s+)(['"]?)(\S+)\1/g) {
+ my @addons = split(m{,}, $2);
+ $seen_nodejs = 1
+ if any { $_ eq 'nodejs' } @addons;
+ }
+
+ } elsif ($line =~ /^([^:]*override_dh_[^:]*):/) {
+ $override_test = 1
+ if $1 eq 'auto_test';
+ }
+ }
+
+ if( $seen_nodejs
+ && !$override_test
+ && !$seen_dh_dynamic) {
+
+ # pkg-js-tools search build test in the following order
+ my @candidates = qw{debian/nodejs/test debian/tests/pkg-js/test};
+
+ my $item = first_value { defined }
+ map { $self->processable->patched->resolve_path($_) } @candidates;
+
+ # Ensure test file contains something
+ if (defined $item) {
+ $self->pointed_hint('pkg-js-tools-test-is-empty', $item->pointer)
+ unless any { /^[^#]*\w/m } $item->bytes;
+
+ } else {
+ $self->hint('pkg-js-tools-test-is-missing');
+ }
+ }
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $item->is_dir;
+
+ return
+ if $self->processable->name =~ /-dbg$/;
+
+ # Warn if a file is installed in old nodejs root dir
+ $self->pointed_hint('nodejs-module-installed-in-usr-lib', $item->pointer)
+ if $item->name =~ m{^usr/lib/nodejs/.*};
+
+ # Warn if package is not installed in a subdirectory of nodejs root
+ # directories
+ $self->pointed_hint('node-package-install-in-nodejs-rootdir',
+ $item->pointer)
+ if $item->name
+ =~ m{^usr/(?:share|lib(?:/[^/]+)?)/nodejs/(?:package\.json|[^/]*\.js)$};
+
+ # Now we have to open package.json
+ return
+ unless $item->is_open_ok;
+
+ # Return an error if a package-lock.json or a yanr.lock file is installed
+ $self->pointed_hint('nodejs-lock-file', $item->pointer)
+ if $item->name
+ =~ m{^usr/(?:share|lib(?:/[^/]+)?)/nodejs/([^/]+)(.*/)(package-lock\.json|yarn\.lock)$};
+
+ # Look only nodejs package.json files
+ return
+ unless $item->name
+ =~ m{^usr/(?:share|lib(?:/[^/]+)?)/nodejs/([^\@/]+|\@[^/]+/[^/]+)(.*/)package\.json$};
+
+ # First regexp arg: directory in /**/nodejs or @foo/bar when dir starts
+ # with '@', following npm registry policy
+ my $dirname = $1;
+ # Second regex arg: subpath in /**/nodejs/module/ (eg: node_modules/foo)
+ my $subpath = $2;
+
+ my $declared = $self->processable->name;
+ my $version = $self->processable->fields->value('Version');
+ $declared .= "( = $version)"
+ if length $version;
+ $version ||= '0-1';
+
+ my $provides
+ = $self->processable->relation('Provides')->logical_and($declared);
+
+ my $content = $item->bytes;
+
+ # Look only valid package.json files
+ my $pac;
+ try {
+ $pac = decode_json($content);
+ die
+ unless length $pac->{name};
+ } catch {
+ return;
+ }
+
+ # Store node module name & version (classification)
+ $self->pointed_hint('nodejs-module', $item->pointer, $pac->{name},
+ $pac->{version} // 'undef');
+
+ # Warn if version is 0.0.0-development
+ $self->pointed_hint('nodejs-missing-version-override',
+ $item->pointer, $pac->{name}, $pac->{version})
+ if $pac->{version} and $pac->{version} =~ /^0\.0\.0-dev/;
+
+ # Warn if module name is not equal to nodejs directory
+ if ($subpath eq $SLASH && $dirname ne $pac->{name}) {
+ $self->pointed_hint('nodejs-module-installed-in-bad-directory',
+ $item->pointer, $pac->{name}, $dirname);
+
+ } else {
+ # Else verify that module is declared at least in Provides: field
+ my $name = 'node-' . lc($pac->{name});
+ # Normalize name following Debian policy
+ # (replace invalid characters by "-")
+ $name =~ s{[/_\@]}{-}g;
+ $name =~ s/-+/-/g;
+
+ $self->pointed_hint('nodejs-module-not-declared', $item->pointer,$name)
+ if $subpath eq $SLASH
+ && !$provides->satisfies($name);
+ }
+
+ return;
+}
+
+sub path_exists {
+ my ($self, $expression) = @_;
+
+ # replace asterisks with proper regex wildcard
+ $expression =~ s{ [*] }{[^/]*}gsx;
+
+ return 1
+ if any { m{^ $expression /? $}sx }
+ @{$self->processable->patched->sorted_list};
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm
new file mode 100644
index 0000000..f916d68
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm
@@ -0,0 +1,85 @@
+# languages/ocaml/byte-code/compiled -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2009 Stephane Glondu
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::ByteCode::Compiled;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has provided_o => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %provided_o;
+
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ for my $count (keys %{$item->ar_info}) {
+
+ my $member = $item->ar_info->{$count}{name};
+ next
+ unless length $member;
+
+ # dirname ends in a slash
+ my $virtual_path = $item->dirname . $member;
+
+ # Note: a .o may be legitimately in several different .a
+ $provided_o{$virtual_path} = $item->name;
+ }
+ }
+
+ return \%provided_o;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $no_extension = $item->basename;
+ $no_extension =~ s{ [.] [^.]+ $}{}x;
+
+ # The .cmx counterpart: for each .cmx file, there must be a
+ # matching .o file, which can be there by itself, or embedded in a
+ # .a file in the same directory
+ # dirname ends with a slash
+ $self->pointed_hint('ocaml-dangling-cmx', $item->pointer)
+ if $item->name =~ m{ [.]cmx $}x
+ && !$item->parent_dir->child($no_extension . '.o')
+ && !exists $self->provided_o->{$item->dirname . $no_extension . '.o'};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm
new file mode 100644
index 0000000..8edeab1
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm
@@ -0,0 +1,63 @@
+# languages/ocaml/byte-code/interface -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2009 Stephane Glondu
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::ByteCode::Interface;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $LAST_ITEM => -1;
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $no_extension = $item->basename;
+ $no_extension =~ s{ [.] [^.]+ $}{}x;
+
+ # for dune
+ my $interface_name = (split(/__/, $no_extension))[$LAST_ITEM];
+
+ # $somename.cmi should be shipped with $somename.mli or $somename.ml
+ $self->pointed_hint('ocaml-dangling-cmi', $item->pointer)
+ if $item->name =~ m{ [.]cmi $}x
+ && !$item->parent_dir->child($interface_name . '.mli')
+ && !$item->parent_dir->child(lc($interface_name) . '.mli')
+ && !$item->parent_dir->child($interface_name . '.ml')
+ && !$item->parent_dir->child(lc($interface_name) . '.ml');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm
new file mode 100644
index 0000000..965f134
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm
@@ -0,0 +1,58 @@
+# languages/ocaml/byte-code/library -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2009 Stephane Glondu
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::ByteCode::Library;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $no_extension = $item->basename;
+ $no_extension =~ s{ [.] [^.]+ $}{}x;
+
+ # For each .cmxa file, there must be a matching .a file (#528367)
+ $self->pointed_hint('ocaml-dangling-cmxa', $item->pointer)
+ if $item->name =~ m{ [.]cmxa $}x
+ && !$item->parent_dir->child($no_extension . '.a');
+
+ # $somename.cmo should usually not be shipped with $somename.cma
+ $self->pointed_hint('ocaml-stray-cmo', $item->pointer)
+ if $item->name =~ m{ [.]cma $}x
+ && $item->parent_dir->child($no_extension . '.cmo');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm
new file mode 100644
index 0000000..767f6b0
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm
@@ -0,0 +1,126 @@
+# languages/ocaml/byte-code/misplaced/package -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2009 Stephane Glondu
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::ByteCode::Misplaced::Package;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(first_value);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+has development_files => (is => 'rw', default => sub { [] });
+
+has is_dev_package => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # is it a development package?
+ return 1
+ if (
+ $self->processable->name =~ m{
+ (?: -dev
+ |\A camlp[45](?:-extra)?
+ |\A ocaml (?:
+ -nox
+ |-interp
+ |-compiler-libs
+ )?
+ )\Z}xsm
+ );
+
+ return 0;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # .cma, .cmo and .cmxs are excluded because they can be plugins
+ push(@{$self->development_files}, $item->name)
+ if $item->name =~ m{ [.] cm (?: i | xa? ) $}x;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $count = scalar @{$self->development_files};
+ my $plural = ($count == 1) ? $EMPTY : 's';
+
+ my $prefix = longest_common_prefix(@{$self->development_files});
+
+ # strip trailing slash
+ $prefix =~ s{ / $}{}x
+ unless $prefix eq $SLASH;
+
+ # non-dev packages should not ship .cmi, .cmx or .cmxa files
+ $self->hint('ocaml-dev-file-in-nondev-package',
+ "$count file$plural in $prefix")
+ if $count > 0
+ && !$self->is_dev_package;
+
+ return;
+}
+
+sub longest_common_prefix {
+ my (@paths) = @_;
+
+ my %prefixes;
+
+ for my $path (@paths) {
+
+ my $truncated = $path;
+
+ # first operation drops the file name
+ while ($truncated =~ s{ / [^/]* $}{}x) {
+ ++$prefixes{$truncated};
+ }
+ }
+
+ my @by_descending_length = reverse sort keys %prefixes;
+
+ my $common = first_value { $prefixes{$_} == @paths } @by_descending_length;
+
+ $common ||= $SLASH;
+
+ return $common;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm
new file mode 100644
index 0000000..68e4f4f
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm
@@ -0,0 +1,105 @@
+# languages/ocaml/byte-code/misplaced/path -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2009 Stephane Glondu
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::ByteCode::Misplaced::Path;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(first_value);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+has misplaced_files => (is => 'rw', default => sub { [] });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # development files outside /usr/lib/ocaml (.cmi, .cmx, .cmxa)
+ return
+ if $item->name =~ m{^ usr/lib/ocaml/ }x;
+
+ # .cma, .cmo and .cmxs are excluded because they can be plugins
+ push(@{$self->misplaced_files}, $item->name)
+ if $item->name =~ m{ [.] cm (?: i | xa? ) $}x;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $count = scalar @{$self->misplaced_files};
+ my $plural = ($count == 1) ? $EMPTY : 's';
+
+ my $prefix = longest_common_prefix(@{$self->misplaced_files});
+
+ # strip trailing slash
+ $prefix =~ s{ / $}{}x
+ unless $prefix eq $SLASH;
+
+ $self->hint(
+ 'ocaml-dev-file-not-in-usr-lib-ocaml',
+ "$count file$plural in $prefix"
+ )if $count > 0;
+
+ return;
+}
+
+sub longest_common_prefix {
+ my (@paths) = @_;
+
+ my %prefixes;
+
+ for my $path (@paths) {
+
+ my $truncated = $path;
+
+ # first operation drops the file name
+ while ($truncated =~ s{ / [^/]* $}{}x) {
+ ++$prefixes{$truncated};
+ }
+ }
+
+ my @by_descending_length = reverse sort keys %prefixes;
+
+ my $common = first_value { $prefixes{$_} == @paths } @by_descending_length;
+
+ $common ||= $SLASH;
+
+ return $common;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm
new file mode 100644
index 0000000..ae14f6b
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm
@@ -0,0 +1,56 @@
+# languages/ocaml/byte-code/plugin -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2009 Stephane Glondu
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::ByteCode::Plugin;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $no_extension = $item->basename;
+ $no_extension =~ s{ [.] [^.]+ $}{}x;
+
+ # For each .cmxs file, there must be a matching .cma or .cmo file
+ # (at least, in library packages)
+ $self->pointed_hint('ocaml-dangling-cmxs', $item->pointer)
+ if $item->name =~ m{ [.]cmxs $}x
+ && !$item->parent_dir->child($no_extension . '.cma')
+ && !$item->parent_dir->child($no_extension . '.cmo')
+ && $self->processable->name =~ /^lib/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm b/lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm
new file mode 100644
index 0000000..8ebad48
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm
@@ -0,0 +1,59 @@
+# languages/ocaml/custom-executable -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::CustomExecutable;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ # Check for OCaml custom executables (#498138)
+ $self->pointed_hint('ocaml-custom-executable', $item->pointer)
+ if $item->file_type =~ m{ \b not [ ] stripped \b }x
+ && $item->file_type =~ m{ \b executable \b }x
+ && $item->strings =~ m{^ Caml1999X0 [0-9] [0-9] $}mx;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ocaml/Meta.pm b/lib/Lintian/Check/Languages/Ocaml/Meta.pm
new file mode 100644
index 0000000..0a9976b
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ocaml/Meta.pm
@@ -0,0 +1,67 @@
+# languages/ocaml/meta -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2009 Stephane Glondu
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ocaml::Meta;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has has_meta => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^ usr/lib/ocaml/ }x;
+
+ # does the package provide a META file?
+ $self->has_meta(1)
+ if $item->name =~ m{ / META (?: [.] | $ ) }x;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $prerequisites = $self->processable->relation('all');
+
+ # If there is a META file, ocaml-findlib should at least be suggested.
+ $self->hint('ocaml-meta-without-suggesting-findlib')
+ if $self->has_meta
+ && !$prerequisites->satisfies('ocaml-findlib:any');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Perl.pm b/lib/Lintian/Check/Languages/Perl.pm
new file mode 100644
index 0000000..c68af47
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Perl.pm
@@ -0,0 +1,125 @@
+# languages/perl -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Perl;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has perl_sources_in_lib => (is => 'rw', default => sub { [] });
+has has_perl_binaries => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # perllocal.pod
+ $self->pointed_hint('package-installs-perllocal-pod', $item->pointer)
+ if $item->name =~ m{^usr/lib/perl.*/perllocal.pod$};
+
+ # .packlist files
+ if ($item->name =~ m{^usr/lib/perl.*/.packlist$}) {
+ $self->pointed_hint('package-installs-packlist', $item->pointer);
+
+ }elsif ($item->name =~ m{^usr/lib/(?:[^/]+/)?perl5/.*\.p[lm]$}) {
+ push @{$self->perl_sources_in_lib}, $item;
+
+ }elsif ($item->name =~ m{^usr/lib/(?:[^/]+/)?perl5/.*\.(?:bs|so)$}) {
+ $self->has_perl_binaries(1);
+ }
+
+ # perl modules
+ if ($item->name =~ m{^usr/(?:share|lib)/perl/\S}) {
+
+ # check if it's the "perl" package itself
+ $self->pointed_hint('perl-module-in-core-directory', $item->pointer)
+ unless $self->processable->source_name eq 'perl';
+ }
+
+ # perl modules using old libraries
+ # we do the same check on perl scripts in checks/scripts
+ my $dep = $self->processable->relation('strong');
+ if ( $item->is_file
+ && $item->name =~ /\.pm$/
+ && !$dep->satisfies('libperl4-corelibs-perl | perl (<< 5.12.3-7)')) {
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+ if (
+ $line =~ m{ (?:do|require)\s+['"] # do/require
+
+ # Huge list of perl4 modules...
+ (abbrev|assert|bigfloat|bigint|bigrat
+ |cacheout|complete|ctime|dotsh|exceptions
+ |fastcwd|find|finddepth|flush|getcwd|getopt
+ |getopts|hostname|importenv|look|newgetopt
+ |open2|open3|pwd|shellwords|stat|syslog
+ |tainted|termcap|timelocal|validate)
+ # ... so they end with ".pl" rather than ".pm"
+ \.pl['"]
+ }xsm
+ ) {
+ my $module = $1;
+
+ $self->pointed_hint('perl-module-uses-perl4-libs-without-dep',
+ $item->pointer($position), "$module.pl");
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ unless ($self->has_perl_binaries) {
+
+ $self->pointed_hint('package-installs-nonbinary-perl-in-usr-lib-perl5',
+ $_->pointer)
+ for @{$self->perl_sources_in_lib};
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Perl/Core/Provides.pm b/lib/Lintian/Check/Languages/Perl/Core/Provides.pm
new file mode 100644
index 0000000..b0a3923
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Perl/Core/Provides.pm
@@ -0,0 +1,83 @@
+# languages/perl/core/provides -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Perl::Core::Provides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Dpkg::Version qw(version_check);
+
+use Lintian::Relation::Version qw(versions_compare);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub always {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ return
+ unless $fields->declares('Version');
+
+ my $version = $fields->unfolded_value('Version');
+
+ my $dversion = Dpkg::Version->new($version);
+ return
+ unless $dversion->is_valid;
+
+ my ($epoch, $upstream, $debian)
+ = ($dversion->epoch, $dversion->version, $dversion->revision);
+
+ my $PERL_CORE_PROVIDES= $self->data->load('fields/perl-provides', '\s+');
+
+ my $name = $fields->value('Package');
+
+ return
+ unless $PERL_CORE_PROVIDES->recognizes($name);
+
+ my $core_version = $PERL_CORE_PROVIDES->value($name);
+
+ my $no_revision = "$epoch:$upstream";
+ return
+ unless version_check($no_revision);
+
+ $self->hint('package-superseded-by-perl', "with $core_version")
+ if versions_compare($core_version, '>=', $no_revision);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm b/lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm
new file mode 100644
index 0000000..fb5e9be
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm
@@ -0,0 +1,124 @@
+# languages/perl/perl4/prerequisites -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Perl::Perl4::Prerequisites;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# check for obsolete perl libraries
+const my $PERL4_PREREQUISITES =>
+ 'libperl4-corelibs-perl:any | perl:any (<< 5.12.3-7)';
+
+has satisfies_perl4_prerequisites => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->processable->relation('strong')
+ ->satisfies($PERL4_PREREQUISITES);
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # Consider /usr/src/ scripts as "documentation"
+ # - packages containing /usr/src/ tend to be "-source" .debs
+ # and usually come with overrides
+ # no checks necessary at all for scripts in /usr/share/doc/
+ # unless they are examples
+ return
+ if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/})
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ return
+ unless length $item->interpreter;
+
+ my $basename = basename($item->interpreter);
+ return
+ unless $basename eq 'perl';
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+ if (
+ $line =~m{ (?:do|require)\s+['"] # do/require
+
+ # Huge list of perl4 modules...
+ (abbrev|assert|bigfloat|bigint|bigrat
+ |cacheout|complete|ctime|dotsh|exceptions
+ |fastcwd|find|finddepth|flush|getcwd|getopt
+ |getopts|hostname|importenv|look|newgetopt
+ |open2|open3|pwd|shellwords|stat|syslog
+ |tainted|termcap|timelocal|validate)
+ # ... so they end with ".pl" rather than ".pm"
+ \.pl['"]
+ }xsm
+ ) {
+
+ my $module = "$1.pl";
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint(
+ 'script-uses-perl4-libs-without-dep',$pointer,
+ "(does not satisfy $PERL4_PREREQUISITES)",$module
+ ) unless $self->satisfies_perl4_prerequisites;
+
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Perl/Perl5.pm b/lib/Lintian/Check/Languages/Perl/Perl5.pm
new file mode 100644
index 0000000..8b138ab
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Perl/Perl5.pm
@@ -0,0 +1,61 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Perl::Perl5;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # Find mentioning of usr/lib/perl5 inside the packaging
+ $self->pointed_hint('mentions-deprecated-usr-lib-perl5-directory',
+ $item->pointer)
+ if $item->basename ne 'changelog'
+ && $item->name =~ m{^ debian/ }sx
+ && $item->name !~ m{^ debian/patches/ }sx
+ && $item->name !~ m{^ debian/ (?:.+\.)? install $}sx
+ && $item->bytes =~ m{^ [^#]* usr/lib/perl5 }msx;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Perl/Yapp.pm b/lib/Lintian/Check/Languages/Perl/Yapp.pm
new file mode 100644
index 0000000..adf3605
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Perl/Yapp.pm
@@ -0,0 +1,55 @@
+# languages/perl/yapp -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Perl::Yapp;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ /\.pm$/;
+
+ my $bytes = $item->bytes;
+ return
+ unless $bytes;
+
+ $self->pointed_hint('source-contains-prebuilt-yapp-parser', $item->pointer)
+ if $bytes
+ =~ /^#\s+This file was generated using Parse::Yapp version [\d.]+/m;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Php.pm b/lib/Lintian/Check/Languages/Php.pm
new file mode 100644
index 0000000..948a7a3
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Php.pm
@@ -0,0 +1,53 @@
+# languages/php -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Php;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # /etc/php/*/mods-available/*.ini
+ if ( $item->is_file
+ && $item->name =~ m{^etc/php/.*/mods-available/.+\.ini$}) {
+
+ $self->pointed_hint('obsolete-comments-style-in-php-ini',
+ $item->pointer)
+ if $item->decoded_utf8 =~ /^\s*#/m;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Php/Composer.pm b/lib/Lintian/Check/Languages/Php/Composer.pm
new file mode 100644
index 0000000..142c1e8
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Php/Composer.pm
@@ -0,0 +1,93 @@
+# languages/php/composer -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Php::Composer;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+ my $source_fields = $control->source_fields;
+
+ for my $field (
+ qw(Build-Depends Build-Depends-Indep
+ Build-Conflicts Build-Conflicts-Indep)
+ ) {
+ next
+ unless $source_fields->declares($field);
+
+ my $position = $source_fields->position($field);
+ my $pointer = $control->item->pointer($position);
+
+ my $raw = $source_fields->value($field);
+ my $relation = Lintian::Relation->new->load($raw);
+
+ my $condition = 'composer:any';
+
+ $self->pointed_hint('composer-prerequisite', $pointer, $field,
+ '(in source paragraph)')
+ if $relation->satisfies($condition);
+ }
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (
+ qw(Pre-Depends Depends Recommends Suggests Breaks
+ Conflicts Provides Replaces Enhances)
+ ) {
+ next
+ unless $installable_fields->declares($field);
+
+ my $position = $installable_fields->position($field);
+ my $pointer = $control->item->pointer($position);
+
+ my $relation
+ = $self->processable->binary_relation($installable, $field);
+
+ my $condition = 'composer:any';
+
+ $self->pointed_hint('composer-prerequisite', $pointer, $field,
+ "(in section for $installable)")
+ if $relation->satisfies($condition);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Php/Embedded.pm b/lib/Lintian/Check/Languages/Php/Embedded.pm
new file mode 100644
index 0000000..2287f09
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Php/Embedded.pm
@@ -0,0 +1,92 @@
+# languages/php/embedded -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Php::Embedded;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my $PHP_EXT = qr{(?i)\.(?:php|inc|dtd)$};
+my %PHP_FILES = (
+ 'libphp-adodb' => qr{(?i)/adodb\.inc\.php$},
+ 'smarty3?' => qr{(?i)/Smarty(?:_Compiler)?\.class\.php$},
+ 'libphp-phpmailer' => qr{(?i)/class\.phpmailer(\.(?:php|inc))+$},
+ 'phpsysinfo' =>
+qr{(?i)/phpsysinfo\.dtd|/class\.(?:Linux|(?:Open|Net|Free|)BSD)\.inc\.php$},
+ 'php-openid' => qr{/Auth/(?:OpenID|Yadis/Yadis)\.php$},
+ 'libphp-snoopy' => qr{(?i)/Snoopy\.class\.(?:php|inc)$},
+ 'php-markdown' => qr{(?i)/markdown\.php$},
+ 'php-geshi' => qr{(?i)/geshi\.php$},
+ 'libphp-pclzip' =>qr{(?i)/(?:class[.-])?pclzip\.(?:inc|lib)?\.php$},
+ 'libphp-phplayersmenu' => qr{(?i)/.*layersmenu.*/(lib/)?PHPLIB\.php$},
+ 'libphp-phpsniff' => qr{(?i)/phpSniff\.(?:class|core)\.php$},
+ 'libphp-jabber' => qr{(?i)/(?:class\.)?jabber\.php$},
+ 'libphp-simplepie' =>
+ qr{(?i)/(?:class[\.-])?simplepie(?:\.(?:php|inc))+$},
+ 'libphp-jpgraph' => qr{(?i)/jpgraph\.php$},
+ 'php-fpdf' => qr{(?i)/fpdf\.php$},
+ 'php-getid3' => qr{(?i)/getid3\.(?:lib\.)?(?:\.(?:php|inc))+$},
+ 'php-php-gettext' => qr{(?i)/(?<!pomo/)streams\.php$},
+ 'libphp-magpierss' => qr{(?i)/rss_parse\.(?:php|inc)$},
+ 'php-simpletest' => qr{(?i)/unit_tester\.php$},
+ 'libsparkline-php' => qr{(?i)/Sparkline\.php$},
+ 'libnusoap-php' => qr{(?i)/(?:class\.)?nusoap\.(?:php|inc)$},
+ 'php-htmlpurifier' => qr{(?i)/HTMLPurifier\.php$},
+ # not yet available in unstable:,
+ # 'libphp-ixr' => qr{(?i)/IXR_Library(?:\.inc|\.php)+$},
+ # 'libphp-kses' => qr{(?i)/(?:class\.)?kses\.php$},
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # embedded PHP
+ for my $provider (keys %PHP_FILES) {
+
+ next
+ if $self->processable->name =~ /^$provider$/;
+
+ next
+ unless $item->name =~ /$PHP_FILES{$provider}/;
+
+ $self->pointed_hint('embedded-php-library', $item->pointer,
+ 'please use',$provider);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Php/Pear.pm b/lib/Lintian/Check/Languages/Php/Pear.pm
new file mode 100644
index 0000000..b73b268
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Php/Pear.pm
@@ -0,0 +1,242 @@
+# langauges/php/pear -- lintian check script -*- perl -*-
+
+# Copyright (C) 2013 Mathieu Parent <math.parent@gmail.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Php::Pear;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(none);
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $DOLLAR => q{$};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ # Don't check package if it doesn't contain a .php file
+ if (none { $_->basename =~ m/\.php$/i && !$_->is_dir }
+ @{$self->processable->patched->sorted_list}){
+ return;
+ }
+
+ my $build_depends = $self->processable->relation('Build-Depends');
+ my $package_type = 'unknown';
+
+ # PEAR or PECL package
+ my $package_xml = $self->processable->patched->lookup('package.xml');
+ my $package2_xml = $self->processable->patched->lookup('package2.xml');
+
+ my $debian_control = $self->processable->debian_control;
+
+ if (defined($package_xml) || defined($package2_xml)) {
+ # Checking source builddep
+ if (!$build_depends->satisfies('pkg-php-tools')) {
+ $self->hint('pear-package-without-pkg-php-tools-builddep');
+
+ } else {
+ # Checking first binary relations
+ my @binaries = $debian_control->installables;
+ my $binary = $binaries[0];
+
+ my $depends
+ = $self->processable->binary_relation($binary, 'Depends');
+ my $recommends
+ = $self->processable->binary_relation($binary, 'Recommends');
+ my $breaks= $self->processable->binary_relation($binary, 'Breaks');
+
+ $self->hint('pear-package-but-missing-dependency', 'Depends')
+ unless $depends->satisfies($DOLLAR . '{phppear:Debian-Depends}');
+
+ $self->hint('pear-package-but-missing-dependency','Recommends')
+ unless $recommends->satisfies(
+ $DOLLAR . '{phppear:Debian-Recommends}');
+
+ $self->hint('pear-package-but-missing-dependency', 'Breaks')
+ unless $breaks->satisfies($DOLLAR . '{phppear:Debian-Breaks}');
+
+ # checking description
+ my $description
+ = $debian_control->installable_fields($binary)
+ ->untrimmed_value('Description');
+
+ $self->hint(
+ 'pear-package-not-using-substvar',
+ $DOLLAR . '{phppear:summary}'
+ )if $description !~ /\$\{phppear:summary\}/;
+
+ $self->hint(
+ 'pear-package-not-using-substvar',
+ $DOLLAR . '{phppear:description}'
+ )if $description !~ /\$\{phppear:description\}/;
+
+ if (defined $package_xml && $package_xml->is_regular_file) {
+
+ # Wild guess package type as in
+ # PEAR_PackageFile_v2::getPackageType()
+ open(my $package_xml_fd, '<', $package_xml->unpacked_path)
+ or die encode_utf8(
+ 'Cannot open ' . $package_xml->unpacked_path);
+
+ while (my $line = <$package_xml_fd>) {
+ if (
+ $line =~ m{\A \s* <
+ (php|extsrc|extbin|zendextsrc|zendextbin)
+ release \s* /? > }xsm
+ ) {
+ $package_type = $1;
+ last;
+ }
+ if ($line =~ /^\s*<bundle\s*\/?>/){
+ $package_type = 'bundle';
+ last;
+ }
+ }
+
+ close $package_xml_fd;
+
+ if ($package_type eq 'extsrc') { # PECL package
+ if (!$build_depends->satisfies('php-dev')) {
+
+ $self->pointed_hint(
+ 'pecl-package-requires-build-dependency',
+ $package_xml->pointer,'php-dev');
+ }
+
+ if (!$build_depends->satisfies('dh-php')) {
+ $self->pointed_hint(
+ 'pecl-package-requires-build-dependency',
+ $package_xml->pointer,'dh-php');
+ }
+ }
+ }
+ }
+ }
+
+ # PEAR channel
+ my $channel_xml = $self->processable->patched->lookup('channel.xml');
+ $self->pointed_hint('pear-channel-without-pkg-php-tools-builddep',
+ $channel_xml->pointer)
+ if defined $channel_xml
+ && !$build_depends->satisfies('pkg-php-tools');
+
+ # Composer package
+ my $composer_json = $self->processable->patched->lookup('composer.json');
+ $self->pointed_hint('composer-package-without-pkg-php-tools-builddep',
+ $composer_json->pointer)
+ if defined $composer_json
+ && !($build_depends->satisfies('pkg-php-tools')
+ || $build_depends->satisfies('dh-sequence-phpcomposer'))
+ && !defined $package_xml
+ && !defined $package2_xml;
+
+ # Check rules
+ if (
+ $build_depends->satisfies('pkg-php-tools')
+ && ( defined $package_xml
+ || defined $package2_xml
+ || defined $channel_xml
+ || defined $composer_json)
+ ) {
+ my $rules = $self->processable->patched->resolve_path('debian/rules');
+ if (defined $rules && $rules->is_open_ok) {
+
+ my $has_buildsystem_phppear = 0;
+ my $has_addon_phppear = 0;
+ my $has_addon_phpcomposer= 0;
+ my $has_addon_php = 0;
+
+ open(my $rules_fd, '<', $rules->unpacked_path)
+ or die encode_utf8('Cannot open ' . $rules->unpacked_path);
+
+ while (my $line = <$rules_fd>) {
+
+ while ($line =~ s/\\$// && defined(my $cont = <$rules_fd>)) {
+ $line .= $cont;
+ }
+
+ next
+ if $line =~ /^\s*\#/;
+
+ $has_buildsystem_phppear = 1
+ if $line
+ =~ /^\t\s*dh\s.*--buildsystem(?:=|\s+)(?:\S+,)*phppear(?:,\S+)*\s/;
+
+ $has_addon_phppear = 1
+ if $line
+ =~ /^\t\s*dh\s.*--with(?:=|\s+)(?:\S+,)*phppear(?:,\S+)*\s/;
+
+ $has_addon_phpcomposer = 1
+ if $line
+ =~ /^\t\s*dh\s.*--with(?:=|\s+)(?:\S+,)*phpcomposer(?:,\S+)*\s/;
+
+ $has_addon_php = 1
+ if $line
+ =~ /^\t\s*dh\s.*--with(?:=|\s+)(?:\S+,)*php(?:,\S+)*\s/;
+ }
+
+ close $rules_fd;
+
+ if ( defined $package_xml
+ || defined $package2_xml
+ || defined $channel_xml) {
+
+ $self->pointed_hint('missing-pkg-php-tools-buildsystem',
+ $rules->pointer, 'phppear')
+ unless $has_buildsystem_phppear;
+
+ $self->pointed_hint('missing-pkg-php-tools-addon',
+ $rules->pointer, 'phppear')
+ unless $has_addon_phppear;
+
+ $self->pointed_hint('missing-pkg-php-tools-addon',
+ $rules->pointer, 'php')
+ if $package_type eq 'extsrc'
+ && !$has_addon_php;
+ }
+
+ if ( !defined $package_xml
+ && !defined $package2_xml
+ && defined $composer_json) {
+
+ $self->pointed_hint('missing-pkg-php-tools-addon',
+ $rules->pointer, 'phpcomposer')
+ unless $has_addon_phpcomposer;
+ }
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Php/Pear/Embedded.pm b/lib/Lintian/Check/Languages/Php/Pear/Embedded.pm
new file mode 100644
index 0000000..dfb1268
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Php/Pear/Embedded.pm
@@ -0,0 +1,92 @@
+# languages/php/pear/embedded -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Php::Pear::Embedded;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my $PEAR_MAGIC = qr{pear[/.]};
+my $PEAR_EXT = qr{(?i)\.php$};
+my %PEAR_FILES = (
+ 'php-auth' => qr{/Auth} . $PEAR_EXT,
+ 'php-auth-http' => qr{/Auth/HTTP} . $PEAR_EXT,
+ 'php-benchmark' => qr{/Benchmark/(?:Timer|Profiler|Iterate)}
+ . $PEAR_EXT,
+ 'php-http' => qr{(?<!/Auth)/HTTP} . $PEAR_EXT,
+ 'php-cache' => qr{/Cache} . $PEAR_EXT,
+ 'php-cache-lite' => qr{/Cache/Lite} . $PEAR_EXT,
+ 'php-compat' => qr{/Compat} . $PEAR_EXT,
+ 'php-config' => qr{/Config} . $PEAR_EXT,
+ 'php-crypt-cbc' => qr{/CBC} . $PEAR_EXT,
+ 'php-date' => qr{/Date} . $PEAR_EXT,
+ 'php-db' => qr{(?<!/Container)/DB} . $PEAR_EXT,
+ 'php-file' => qr{(?<!/Container)/File} . $PEAR_EXT,
+ 'php-log' =>
+ qr{(?:/Log/(?:file|error_log|null|syslog|sql\w*)|/Log)} . $PEAR_EXT,
+ 'php-mail' => qr{/Mail} . $PEAR_EXT,
+ 'php-mail-mime' => qr{(?i)/mime(Part)?} . $PEAR_EXT,
+ 'php-mail-mimedecode' => qr{/mimeDecode} . $PEAR_EXT,
+ 'php-net-ftp' => qr{/FTP} . $PEAR_EXT,
+ 'php-net-imap' => qr{(?<!/Container)/IMAP} . $PEAR_EXT,
+ 'php-net-ldap' => qr{(?<!/Container)/LDAP} . $PEAR_EXT,
+ 'php-net-smtp' => qr{/SMTP} . $PEAR_EXT,
+ 'php-net-socket' => qr{(?<!/FTP)/Socket} . $PEAR_EXT,
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # embedded PEAR
+ for my $provider (keys %PEAR_FILES) {
+
+ next
+ if $self->processable->name =~ /^$provider$/;
+
+ next
+ unless $item->name =~ /$PEAR_FILES{$provider}/;
+
+ next
+ unless length $item->bytes_match($PEAR_MAGIC);
+
+ $self->pointed_hint('embedded-pear-module', $item->pointer,
+ 'please use',$provider);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python.pm b/lib/Lintian/Check/Languages/Python.pm
new file mode 100644
index 0000000..089fce4
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python.pm
@@ -0,0 +1,516 @@
+# languages/python -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2016 Chris Lamb
+# Copyright (C) 2020 Louis-Philippe Veronneau <pollo@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation;
+use Lintian::Relation::Version qw(versions_lte);
+
+const my $EMPTY => q{};
+const my $ARROW => q{ -> };
+const my $DOLLAR => q{$};
+
+const my $PYTHON3_MAJOR => 3;
+const my $PYTHON2_MIGRATION_MAJOR => 2;
+const my $PYTHON2_MIGRATION_MINOR => 6;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my @FIELDS = qw(Depends Pre-Depends Recommends Suggests);
+my @IGNORE = qw(-dev$ -docs?$ -common$ -tools$);
+my @PYTHON2 = qw(python2:any python2.7:any python2-dev:any);
+my @PYTHON3 = qw(python3:any python3-dev:any);
+
+my %DJANGO_PACKAGES = (
+ '^python3-django-' => 'python3-django',
+ '^python2?-django-' => 'python-django',
+);
+
+my %REQUIRED_DEPENDS = (
+ 'python2' => 'python2-minimal:any | python2:any',
+ 'python3' => 'python3-minimal:any | python3:any',
+);
+
+my %MISMATCHED_SUBSTVARS = (
+ '^python3-.+' => $DOLLAR . '{python:Depends}',
+ '^python2?-.+' => $DOLLAR . '{python3:Depends}',
+);
+
+has ALLOWED_PYTHON_FILES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('files/allowed-python-files');
+ }
+);
+has GENERIC_PYTHON_MODULES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('files/generic-python-modules');
+ }
+);
+
+my @VERSION_FIELDS = qw(X-Python-Version XS-Python-Version X-Python3-Version);
+
+has correct_location => (is => 'rw', default => sub { {} });
+
+sub source {
+ my ($self) = @_;
+
+ my @installable_names = $self->processable->debian_control->installables;
+ for my $installable_name (@installable_names) {
+ # Python 2 modules
+ if ($installable_name =~ /^python2?-(.*)$/) {
+ my $suffix = $1;
+
+ next
+ if any { $installable_name =~ /$_/ } @IGNORE;
+
+ next
+ if any { $_ eq "python3-${suffix}" } @installable_names;
+
+ # Don't trigger if we ship any Python 3 module
+ next
+ if any {
+ $self->processable->binary_relation($_, 'all')
+ ->satisfies($DOLLAR . '{python3:Depends}')
+ }@installable_names;
+
+ $self->hint('python-foo-but-no-python3-foo', $installable_name);
+ }
+ }
+
+ my $build_all = $self->processable->relation('Build-Depends-All');
+ $self->hint('build-depends-on-python-sphinx-only')
+ if $build_all->satisfies('python-sphinx')
+ && !$build_all->satisfies('python3-sphinx');
+
+ $self->hint(
+ 'alternatively-build-depends-on-python-sphinx-and-python3-sphinx')
+ if $self->processable->fields->value('Build-Depends')
+ =~ /\bpython-sphinx\s+\|\s+python3-sphinx\b/;
+
+ my $debian_control = $self->processable->debian_control;
+
+ # Mismatched substvars
+ for my $regex (keys %MISMATCHED_SUBSTVARS) {
+ my $substvar = $MISMATCHED_SUBSTVARS{$regex};
+
+ for my $installable_name ($debian_control->installables) {
+
+ next
+ if any { $installable_name =~ /$_/ } @IGNORE;
+
+ next
+ if $installable_name !~ qr/$regex/;
+
+ $self->hint('mismatched-python-substvar', $installable_name,
+ $substvar)
+ if $self->processable->binary_relation($installable_name, 'all')
+ ->satisfies($substvar);
+ }
+ }
+
+ my $VERSIONS = $self->data->load('python/versions', qr/\s*=\s*/);
+
+ for my $field (@VERSION_FIELDS) {
+
+ next
+ unless $debian_control->source_fields->declares($field);
+
+ my $pyversion= $debian_control->source_fields->value($field);
+
+ my @valid = (
+ ['\d+\.\d+', '\d+\.\d+'],['\d+\.\d+'],
+ ['\>=\s*\d+\.\d+', '\<\<\s*\d+\.\d+'],['\>=\s*\d+\.\d+'],
+ ['current', '\>=\s*\d+\.\d+'],['current'],
+ ['all']
+ );
+
+ my @pyversion = split(/\s*,\s*/, $pyversion);
+
+ if ($pyversion =~ m/^current/) {
+ $self->hint('python-version-current-is-deprecated', $field);
+ }
+
+ if (@pyversion > 2) {
+ if (any { !/^\d+\.\d+$/ } @pyversion) {
+ $self->hint('malformed-python-version', $field, $pyversion);
+ }
+ } else {
+ my $okay = 0;
+ for my $rule (@valid) {
+ if (
+ $pyversion[0] =~ /^$rule->[0]$/
+ && (
+ (
+ $pyversion[1]
+ && $rule->[1]
+ && $pyversion[1] =~ /^$rule->[1]$/
+ )
+ || (!$pyversion[1] && !$rule->[1])
+ )
+ ) {
+ $okay = 1;
+ last;
+ }
+ }
+ $self->hint('malformed-python-version', $field, $pyversion)
+ unless $okay;
+ }
+
+ if ($pyversion =~ /\b(([23])\.\d+)$/) {
+ my ($v, $major) = ($1, $2);
+ my $old = $VERSIONS->value("old-python$major");
+ my $ancient = $VERSIONS->value("ancient-python$major");
+
+ if (versions_lte($v, $ancient)) {
+ $self->hint('ancient-python-version-field', $field, $v);
+ } elsif (versions_lte($v, $old)) {
+ $self->hint('old-python-version-field', $field, $v);
+ }
+ }
+ }
+
+ $self->hint('source-package-encodes-python-version')
+ if $self->processable->name =~ m/^python\d-/
+ && $self->processable->name ne 'python3-defaults';
+
+ my $build_depends = Lintian::Relation->new;
+ $build_depends->load_norestriction(
+ $self->processable->fields->value('Build-Depends'));
+
+ my $pyproject= $self->processable->patched->resolve_path('pyproject.toml');
+ if (defined $pyproject && $pyproject->is_open_ok) {
+
+ my %PYPROJECT_PREREQUISITES = (
+ 'poetry.core.masonry.api' => 'python3-poetry-core:any',
+ 'flit_core.buildapi' => 'flit:any',
+ 'setuptools.build_meta' => 'python3-setuptools:any',
+ 'pdm.pep517.api' => 'python3-pdm-pep517:any',
+ 'hatchling.build' => 'python3-hatchling:any',
+ 'mesonpy' => 'python3-mesonpy:any',
+ 'sipbuild.api' => 'python3-sipbuild:any'
+ );
+
+ open(my $fd, '<', $pyproject->unpacked_path)
+ or die encode_utf8('Cannot open ' . $pyproject->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $pyproject->pointer($position);
+
+ # In theory, TOML only uses double quotes. In practice, that's not
+ # true and only matching for double quotes introduce false negatives
+ if ($line =~ m{^ \s* build-backend \s* = \s* "([^"]+)" }x
+ || $line =~ m{^ \s* build-backend \s* = \s* '([^"]+)' }x) {
+
+ my $backend = $1;
+
+ $self->pointed_hint('uses-poetry-cli', $pointer)
+ if $backend eq 'poetry.core.masonry.api'
+ && $build_depends->satisfies('python3-poetry:any')
+ && !$build_depends->satisfies('python3-poetry-core:any');
+
+ $self->pointed_hint('uses-pdm-cli', $pointer)
+ if $backend eq 'pdm.pep517.api'
+ && $build_depends->satisfies('python3-pdm:any')
+ && !$build_depends->satisfies('python3-pdm-pep517:any');
+
+ if (exists $PYPROJECT_PREREQUISITES{$backend}) {
+
+ my $prerequisites = $PYPROJECT_PREREQUISITES{$backend}
+ . ', pybuild-plugin-pyproject:any';
+
+ $self->pointed_hint(
+ 'missing-prerequisite-for-pyproject-backend',
+ $pointer, $backend,"(does not satisfy $prerequisites)")
+ if !$build_all->satisfies($prerequisites);
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+ }
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # .pyc/.pyo (compiled Python files)
+ # skip any file installed inside a __pycache__ directory
+ # - we have a separate check for that directory.
+ $self->pointed_hint('package-installs-python-bytecode', $item->pointer)
+ if $item->name =~ /\.py[co]$/
+ && $item->name !~ m{/__pycache__/};
+
+ # __pycache__ (directory for pyc/pyo files)
+ $self->pointed_hint('package-installs-python-pycache-dir', $item->pointer)
+ if $item->is_dir
+ && $item->name =~ m{/__pycache__/};
+
+ if ( $item->is_file
+ && $item->name
+ =~ m{^usr/lib/debug/usr/lib/pyshared/(python\d?(?:\.\d+))/(.+)$}) {
+
+ my $correct = "usr/lib/debug/usr/lib/pymodules/$1/$2";
+ $self->pointed_hint('python-debug-in-wrong-location',
+ $item->pointer, "better: $correct");
+ }
+
+ # .egg (Python egg files)
+ $self->pointed_hint('package-installs-python-egg', $item->pointer)
+ if $item->name =~ /\.egg$/
+ && ( $item->name =~ m{^usr/lib/python\d+(?:\.\d+/)}
+ || $item->name =~ m{^usr/lib/pyshared}
+ || $item->name =~ m{^usr/share/});
+
+ # /usr/lib/site-python
+ $self->pointed_hint('file-in-usr-lib-site-python', $item->pointer)
+ if $item->name =~ m{^usr/lib/site-python/\S};
+
+ # pythonX.Y extensions
+ if ( $item->name =~ m{^usr/lib/python\d\.\d/\S}
+ && $item->name !~ m{^usr/lib/python\d\.\d/(?:site|dist)-packages/}){
+
+ $self->pointed_hint('third-party-package-in-python-dir',$item->pointer)
+ unless $self->processable->source_name =~ m/^python(?:\d\.\d)?$/
+ || $self->processable->source_name =~ m{\A python\d?-
+ (?:stdlib-extensions|profiler|old-doctools) \Z}xsm;
+ }
+
+ # ---------------- Python file locations
+ # - The Python people kindly provided the following table.
+ # good:
+ # /usr/lib/python2.5/site-packages/
+ # /usr/lib/python2.6/dist-packages/
+ # /usr/lib/python2.7/dist-packages/
+ # /usr/lib/python3/dist-packages/
+ #
+ # bad:
+ # /usr/lib/python2.5/dist-packages/
+ # /usr/lib/python2.6/site-packages/
+ # /usr/lib/python2.7/site-packages/
+ # /usr/lib/python3.*/*-packages/
+ if (
+ $item->name =~ m{\A
+ (usr/lib/debug/)?
+ usr/lib/python(\d+(?:\.\d+)?)/
+ ((?:site|dist)-packages)/(.+)
+ \Z}xsm
+ ){
+ my ($debug, $pyver, $actual_package_dir, $relative) = ($1, $2, $3, $4);
+ $debug //= $EMPTY;
+
+ my ($pmaj, $pmin) = split(m{\.}, $pyver, 2);
+ $pmin //= 0;
+
+ next
+ if $pmaj < $PYTHON2_MIGRATION_MAJOR;
+
+ my ($module_name) = ($relative =~ m{^([^/]+)});
+
+ my $actual_python_libpath = "usr/lib/python$pyver/";
+ my $specified_python_libpath = "usr/lib/python$pmaj/";
+
+ # for python 2.X, folder was python2.X and not python2
+ $specified_python_libpath = $actual_python_libpath
+ if $pmaj < $PYTHON3_MAJOR;
+
+ my $specified_package_dir = 'dist-packages';
+
+ # python 2.4 and 2.5
+ $specified_package_dir = 'site-packages'
+ if $pmaj == $PYTHON2_MIGRATION_MAJOR
+ && $pmin < $PYTHON2_MIGRATION_MINOR;
+
+ my $actual_module_path
+ = $debug. $actual_python_libpath. "$actual_package_dir/$module_name";
+ my $specified_module_path
+ = $debug
+ . $specified_python_libpath
+ . "$specified_package_dir/$module_name";
+
+ $self->correct_location->{$actual_module_path} = $specified_module_path
+ unless $actual_module_path eq $specified_module_path;
+
+ for my $regex ($self->GENERIC_PYTHON_MODULES->all) {
+ $self->pointed_hint('python-module-has-overly-generic-name',
+ $item->pointer, "($1)")
+ if $relative =~ m{^($regex)(?:\.py|/__init__\.py)$}i;
+ }
+
+ $self->pointed_hint('unknown-file-in-python-module-directory',
+ $item->pointer)
+ if $item->is_file
+ && $relative eq $item->basename # "top-level"
+ &&!$self->ALLOWED_PYTHON_FILES->matches_any($item->basename, 'i');
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint(
+ 'python-module-in-wrong-location',
+ $_ . $ARROW . $self->correct_location->{$_}
+ )for keys %{$self->correct_location};
+
+ my $deps
+ = $self->processable->relation('all')
+ ->logical_and($self->processable->relation('Provides'),
+ $self->processable->name);
+
+ my @entries
+ = $self->processable->changelog
+ ? @{$self->processable->changelog->entries}
+ : ();
+
+ # Check for missing dependencies
+ if ($self->processable->name !~ /-dbg$/) {
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ if ( $item->is_file
+ && $item->name
+ =~ m{^usr/lib/(?<version>python[23])[\d.]*/(?:site|dist)-packages}
+ && !$deps->satisfies($REQUIRED_DEPENDS{$+{version}})) {
+
+ $self->hint('python-package-missing-depends-on-python');
+
+ last;
+ }
+ }
+ }
+
+ # Check for duplicate dependencies
+ for my $field (@FIELDS) {
+ my $dep = $self->processable->relation($field);
+ FIELD: for my $py2 (@PYTHON2) {
+ for my $py3 (@PYTHON3) {
+
+ if ($dep->satisfies($py2) && $dep->satisfies($py3)) {
+ $self->hint('depends-on-python2-and-python3',
+ $field, "(satisfies $py2, $py3)");
+ last FIELD;
+ }
+ }
+ }
+ }
+
+ my $pkg = $self->processable->name;
+
+ # Python 2 modules
+ $self->hint('new-package-should-not-package-python2-module',
+ $self->processable->name)
+ if $self->processable->name =~ / ^ python2? - /msx
+ && (none { $pkg =~ m{ $_ }x } @IGNORE)
+ && @entries == 1
+ && $entries[0]->Changes
+ !~ / \b python [ ]? 2 (?:[.]x)? [ ] (?:variant|version) \b /imsx
+ && $entries[0]->Changes !~ / \Q$pkg\E /msx;
+
+ # Python applications
+ if ($self->processable->name !~ /^python[23]?-/
+ && (none { $_ eq $self->processable->name } @PYTHON2)) {
+ for my $field (@FIELDS) {
+ for my $dep (@PYTHON2) {
+
+ $self->hint(
+ 'dependency-on-python-version-marked-for-end-of-life',
+ $field, "(satisfies $dep)")
+ if $self->processable->relation($field)->satisfies($dep);
+ }
+ }
+ }
+
+ # Django modules
+ for my $regex (keys %DJANGO_PACKAGES) {
+ my $basepkg = $DJANGO_PACKAGES{$regex};
+
+ next
+ if $self->processable->name !~ /$regex/;
+
+ next
+ if any { $self->processable->name =~ /$_/ } @IGNORE;
+
+ $self->hint('django-package-does-not-depend-on-django', $basepkg)
+ unless $self->processable->relation('strong')->satisfies($basepkg);
+ }
+
+ if (
+ $self->processable->name =~ /^python([23]?)-/
+ && (none { $self->processable->name =~ /$_/ } @IGNORE)
+ ) {
+ my $version = $1 || '2'; # Assume python-foo is a Python 2.x package
+ my @prefixes = ($version eq '2') ? 'python3' : qw(python python2);
+
+ for my $field (@FIELDS) {
+ for my $prefix (@prefixes) {
+
+ my $visit = sub {
+ my $rel = $_;
+ return if any { $rel =~ /$_/ } @IGNORE;
+ $self->hint(
+'python-package-depends-on-package-from-other-python-variant',
+ "$field: $rel"
+ ) if /^$prefix-/;
+ };
+
+ $self->processable->relation($field)
+ ->visit($visit, Lintian::Relation::VISIT_PRED_NAME);
+ }
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm b/lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm
new file mode 100644
index 0000000..fe2df7f
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm
@@ -0,0 +1,88 @@
+# languages/python/bogus-prerequisites -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python::BogusPrerequisites;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ $self->what_is_python($self->processable->source_name,
+ qw{Depends Pre-Depends Recommends});
+
+ return;
+}
+
+sub source {
+ my ($self) = @_;
+
+ $self->what_is_python($self->processable->name,
+ qw{Build-Depends Build-Depends-Indep Build-Depends-Arch});
+
+ return;
+}
+
+sub what_is_python {
+ my ($self, $source, @fields) = @_;
+
+ # see Bug#973011
+ my @WHAT_IS_PYTHON = qw(
+ python-is-python2:any
+ python-dev-is-python2:any
+ python-is-python3:any
+ python-dev-is-python3:any
+ );
+
+ my %BOGUS_PREREQUISITES;
+
+ unless ($source eq 'what-is-python') {
+
+ for my $unwanted (@WHAT_IS_PYTHON) {
+
+ $BOGUS_PREREQUISITES{$unwanted}
+ = [grep {$self->processable->relation($_)->satisfies($unwanted)}
+ @fields];
+ }
+ }
+
+ for my $unwanted (keys %BOGUS_PREREQUISITES) {
+
+ $self->hint('bogus-python-prerequisite', $_, "(satisfies $unwanted)")
+ for @{$BOGUS_PREREQUISITES{$unwanted}};
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python/DistOverrides.pm b/lib/Lintian/Check/Languages/Python/DistOverrides.pm
new file mode 100644
index 0000000..2dadeb6
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python/DistOverrides.pm
@@ -0,0 +1,80 @@
+# languages/python/dist-overrides -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python::DistOverrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+sub source {
+ my ($self) = @_;
+
+ my $override_file
+ = $self->processable->patched->resolve_path('debian/py3dist-overrides');
+ return
+ unless defined $override_file;
+
+ my $contents = $override_file->decoded_utf8;
+ return
+ unless length $contents;
+
+ # strip comments
+ $contents =~ s/^\s*\#.*$//mg;
+
+ # strip empty lines
+ $contents =~ s/^\s*$//mg;
+
+ # trim leading spaces
+ $contents =~ s/^\s*//mg;
+
+ my @lines = split(/\n/, $contents);
+
+ # get first component from each line
+ my @identifiers
+ = grep { defined } map { (split($SPACE, $_, 2))[0] } @lines;
+
+ my %count;
+ $count{$_}++ for @identifiers;
+
+ my @duplicates = grep { $count{$_} > 1 } uniq @identifiers;
+
+ $self->hint('duplicate-p3dist-override', $_) for @duplicates;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python/Distutils.pm b/lib/Lintian/Check/Languages/Python/Distutils.pm
new file mode 100644
index 0000000..cbc30ce
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python/Distutils.pm
@@ -0,0 +1,77 @@
+# languages/python/distutils -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2022 Louis-Philippe Véronneau <pollo@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python::Distutils;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my $PYTHON3_DEPEND
+ = 'python3:any | python3-dev:any | python3-all:any | python3-all-dev:any';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ my $build_all = $self->processable->relation('Build-Depends-All');
+
+ # Skip if the package doesn't depend on python
+ return
+ unless $build_all->satisfies($PYTHON3_DEPEND);
+
+ # Skip if it's not a python file
+ return
+ unless $item->name =~ /\.py$/;
+
+ # Skip if we can't open the file
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('uses-python-distutils', $pointer)
+ if $line =~ m{^from distutils} || $line =~ m{^import distutils};
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python/Feedparser.pm b/lib/Lintian/Check/Languages/Python/Feedparser.pm
new file mode 100644
index 0000000..da716e7
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python/Feedparser.pm
@@ -0,0 +1,54 @@
+# languages/python/feedparser -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python::Feedparser;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # embedded Feedparser library
+ $self->pointed_hint('embedded-feedparser-library', $item->pointer)
+ if $item->name =~ m{ / feedparser[.]py $}x
+ && $item->bytes =~ /Universal feed parser/
+ && $self->processable->source_name ne 'feedparser';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python/Homepage.pm b/lib/Lintian/Check/Languages/Python/Homepage.pm
new file mode 100644
index 0000000..18a0470
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python/Homepage.pm
@@ -0,0 +1,59 @@
+# languages/python/homepage -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python::Homepage;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+ if ($fields->declares('Homepage')) {
+
+ my $homepage = $fields->value('Homepage');
+
+ # see Bug#981932
+ $self->hint('pypi-homepage', $homepage)
+ if $homepage
+ =~ m{^http s? :// (?:www [.])? pypi (:?[.] python)? [.] org/}isx;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python/Obsolete.pm b/lib/Lintian/Check/Languages/Python/Obsolete.pm
new file mode 100644
index 0000000..e810faa
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python/Obsolete.pm
@@ -0,0 +1,63 @@
+# languages/python/obsolete -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python::Obsolete;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $pycompat= $self->processable->patched->resolve_path('debian/pycompat');
+
+ $self->pointed_hint('debian-pycompat-is-obsolete', $pycompat->pointer)
+ if defined $pycompat
+ && $pycompat->is_file;
+
+ my $pyversions
+ = $self->processable->patched->resolve_path('debian/pyversions');
+
+ $self->pointed_hint('debian-pyversions-is-obsolete', $pyversions->pointer)
+ if defined $pyversions
+ && $pyversions->is_file;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Python/Scripts.pm b/lib/Lintian/Check/Languages/Python/Scripts.pm
new file mode 100644
index 0000000..988b915
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Python/Scripts.pm
@@ -0,0 +1,54 @@
+# languages/python/scripts -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2016 Chris Lamb
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Python::Scripts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{(?:usr/)?bin/[^/]+};
+
+ return
+ unless $item->is_script;
+
+ $self->pointed_hint('script-uses-unversioned-python-in-shebang',
+ $item->pointer)
+ if $item->interpreter =~ m{^(?:/usr/bin/)?python$};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/R.pm b/lib/Lintian/Check/Languages/R.pm
new file mode 100644
index 0000000..daa8462
--- /dev/null
+++ b/lib/Lintian/Check/Languages/R.pm
@@ -0,0 +1,74 @@
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 1999 Joey Hess
+# Copyright (C) 2000 Sean 'Shaleh' Perry
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2007 Russ Allbery
+# Copyright (C) 2013-2018 Bastien ROUCARIES
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::R;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $RDATA_MAGIC_LENGTH => 4;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # Ensure we have a README.source for R data files
+ if ( $item->basename =~ /\.(?:rda|Rda|rdata|Rdata|RData)$/
+ && $item->is_open_ok
+ && $item->file_type =~ /gzip compressed data/
+ && !$self->processable->patched->resolve_path('debian/README.source')){
+
+ open(my $fd, '<:gzip', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ read($fd, my $magic, $RDATA_MAGIC_LENGTH)
+ or die encode_utf8('Cannot read from ' . $item->unpacked_path);
+
+ close($fd);
+
+ $self->pointed_hint('r-data-without-readme-source', $item->pointer)
+ if $magic eq 'RDX2';
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/R/Architecture.pm b/lib/Lintian/Check/Languages/R/Architecture.pm
new file mode 100644
index 0000000..3ee0bd2
--- /dev/null
+++ b/lib/Lintian/Check/Languages/R/Architecture.pm
@@ -0,0 +1,69 @@
+# languages/r/architecture -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::R::Architecture;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has have_r_files => (is => 'rw', default => 0);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ if $item->is_dir;
+
+ $self->have_r_files(1)
+ if $item->name =~ m{^usr/lib/R/.*/DESCRIPTION$}
+ && $item->decoded_utf8 =~ /^NeedsCompilation: no/m;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint('r-package-not-arch-all')
+ if $self->processable->name =~ /^r-(?:cran|bioc|other)-/
+ && $self->have_r_files
+ && $self->processable->fields->value('Architecture') ne 'all';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/R/SiteLibrary.pm b/lib/Lintian/Check/Languages/R/SiteLibrary.pm
new file mode 100644
index 0000000..1ac6ac9
--- /dev/null
+++ b/lib/Lintian/Check/Languages/R/SiteLibrary.pm
@@ -0,0 +1,71 @@
+# languages/r/site-library -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Dylan Aissi
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::R::SiteLibrary;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has r_site_libraries => (is => 'rw', default => sub { [] });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # R site libraries
+ if ($item->name =~ m{^usr/lib/R/site-library/(.*)/DESCRIPTION$}) {
+ push(@{$self->r_site_libraries}, $1);
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint('ships-r-site-library', $_) for @{$self->r_site_libraries};
+
+ return
+ unless @{$self->r_site_libraries};
+
+ my $depends = $self->processable->relation('strong');
+
+ # no version allowed for virtual package; no alternatives
+ $self->hint('requires-r-api')
+ unless $depends->matches(qr/^r-api-[\w\d+-.]+$/,
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Ruby.pm b/lib/Lintian/Check/Languages/Ruby.pm
new file mode 100644
index 0000000..563f740
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Ruby.pm
@@ -0,0 +1,72 @@
+# languages/ruby -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# Parts of the code were taken from the old check script, which
+# was Copyright (C) 1998 Richard Braakman (also licensed under the
+# GPL 2 or higher)
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Ruby;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+ if ($fields->declares('Homepage')) {
+
+ my $homepage = $fields->value('Homepage');
+
+ # rubygems itself is okay; see Bug#981935
+ $self->hint('rubygem-homepage', $homepage)
+ if $homepage
+ =~ m{^http s? :// (?:www [.])? rubygems [.] org/gems/}isx;
+ }
+
+ return;
+}
+
+sub binary {
+ my ($self) = @_;
+
+ my @prerequisites
+ = $self->processable->fields->trimmed_list('Depends', qr/,/);
+
+ my @ruby_interpreter = grep { / \b ruby-interpreter \b /x } @prerequisites;
+
+ $self->hint('ruby-interpreter-is-deprecated', $_)for @ruby_interpreter;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Languages/Rust.pm b/lib/Lintian/Check/Languages/Rust.pm
new file mode 100644
index 0000000..140134f
--- /dev/null
+++ b/lib/Lintian/Check/Languages/Rust.pm
@@ -0,0 +1,69 @@
+# languages/rust -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Sylvestre Ledru
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Languages::Rust;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $debian_control = $self->processable->debian_control;
+ for my $installable ($debian_control->installables) {
+
+ my $fields = $debian_control->installable_fields($installable);
+ my $extended = $fields->text('Description');
+
+ # drop synopsis
+ $extended =~ s/^ [^\n]* \n //sx;
+
+ $self->hint('rust-boilerplate', $installable)
+ if $extended
+ =~ /^ \QThis package contains the following binaries built from the Rust crate\E /isx;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint('empty-rust-library-declares-provides')
+ if $self->processable->name =~ /^librust-/
+ && $self->processable->not_just_docs
+ && length $self->processable->fields->value('Provides');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/DebugSymbols.pm b/lib/Lintian/Check/Libraries/DebugSymbols.pm
new file mode 100644
index 0000000..4f04e6f
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/DebugSymbols.pm
@@ -0,0 +1,59 @@
+# libraries/debug-symbols -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::DebugSymbols;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ # stripped but a debug or profiling library?
+ $self->pointed_hint('stripped-library', $item->pointer)
+ if $item->file_type !~ m{\bnot stripped\b}
+ && $item->name =~ m{^ (?:usr/)? lib/ (?: debug | profile ) / }x
+ && $item->size;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Embedded.pm b/lib/Lintian/Check/Libraries/Embedded.pm
new file mode 100644
index 0000000..502af47
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Embedded.pm
@@ -0,0 +1,124 @@
+# libraries/embedded -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Embedded;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $SPACE => q{ };
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has EMBEDDED_LIBRARIES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %embedded_libraries;
+
+ my $data
+ = $self->data->load('binaries/embedded-libs',qr{ \s*+ [|][|] }x);
+
+ for my $label ($data->all) {
+
+ my $details = $data->value($label);
+
+ my ($pairs, $pattern) = split(m{ [|][|] }x, $details, 2);
+
+ my %result;
+ for my $kvpair (split($SPACE, $pairs)) {
+
+ my ($key, $value) = split(/=/, $kvpair, 2);
+ $result{$key} = $value;
+ }
+
+ my $lc= List::Compare->new([keys %result],
+ [qw{libname source source-regex}]);
+ my @unknown = $lc->get_Lonly;
+
+ die encode_utf8(
+"Unknown options @unknown for $label (in binaries/embedded-libs)"
+ )if @unknown;
+
+ die encode_utf8(
+"Both source and source-regex used for $label (in binaries/embedded-libs)"
+ )if length $result{source} && length $result{'source-regex'};
+
+ $result{match} = qr/$pattern/;
+
+ $result{libname} //= $label;
+ $result{source} //= $label;
+
+ $embedded_libraries{$label} = \%result;
+ }
+
+ return \%embedded_libraries;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^ [^,]* \b ELF \b /x;
+
+ for my $embedded_name (keys %{$self->EMBEDDED_LIBRARIES}) {
+
+ my $library_data = $self->EMBEDDED_LIBRARIES->{$embedded_name};
+
+ next
+ if length $library_data->{'source-regex'}
+ && $self->processable->source_name=~ $library_data->{'source-regex'};
+
+ next
+ if length $library_data->{source}
+ && $self->processable->source_name eq $library_data->{source};
+
+ $self->pointed_hint('embedded-library', $item->pointer,
+ $library_data->{libname})
+ if $item->strings =~ $library_data->{match};
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Exit.pm b/lib/Lintian/Check/Libraries/Shared/Exit.pm
new file mode 100644
index 0000000..5788808
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Exit.pm
@@ -0,0 +1,72 @@
+# libraries/shared/exit -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Exit;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# not presently used
+#my $UNKNOWN_SHARED_LIBRARY_EXCEPTIONS
+# = $self->data->load('shared-libs/unknown-shared-library-exceptions');
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # shared library
+ return
+ unless @{$item->elf->{SONAME} // [] };
+
+ my @symbols = grep { $_->section eq '.text' || $_->section eq 'UND' }
+ @{$item->elf->{SYMBOLS} // []};
+
+ my @symbol_names = map { $_->name } @symbols;
+
+ # If it has an INTERP section it might be an application with
+ # a SONAME (hi openjdk-6, see #614305). Also see the comment
+ # for "shared-library-is-executable" below.
+ $self->pointed_hint('exit-in-shared-library', $item->pointer)
+ if (any { m/^_?exit$/ } @symbol_names)
+ && (none { $_ eq 'fork' } @symbol_names)
+ && !length $item->elf->{INTERP};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/FilePermissions.pm b/lib/Lintian/Check/Libraries/Shared/FilePermissions.pm
new file mode 100644
index 0000000..663205e
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/FilePermissions.pm
@@ -0,0 +1,72 @@
+# libraries/shared/file-permissions -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::FilePermissions;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $WIDELY_READABLE => oct(644);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # shared library
+ return
+ unless @{$item->elf->{SONAME} // [] };
+
+ # Yes. But if the library has an INTERP section, it's
+ # designed to do something useful when executed, so don't
+ # report an error. Also give ld.so a pass, since it's
+ # special.
+ $self->pointed_hint('shared-library-is-executable',
+ $item->pointer, $item->octal_permissions)
+ if $item->is_executable
+ && !$item->elf->{INTERP}
+ && $item->name !~ m{^lib.*/ld-[\d.]+\.so$};
+
+ $self->pointed_hint('odd-permissions-on-shared-library',
+ $item->pointer, $item->octal_permissions)
+ if !$item->is_executable
+ && $item->operm != $WIDELY_READABLE;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Links.pm b/lib/Lintian/Check/Libraries/Shared/Links.pm
new file mode 100644
index 0000000..e25d3fd
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Links.pm
@@ -0,0 +1,167 @@
+# libraries/shared/links -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Links;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(none);
+
+const my $ARROW => q{->};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has development_packages => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @development_packages;
+
+ for my $installable ($self->group->get_installables) {
+
+ push(@development_packages, $installable)
+ if $installable->name =~ /-dev$/
+ && $installable->relation('strong')
+ ->satisfies($self->processable->name);
+ }
+
+ return \@development_packages;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # shared library
+ return
+ unless @{$item->elf->{SONAME} // [] };
+
+ my $soname = $item->elf->{SONAME}[0];
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+ return
+ if none { $item->dirname eq $_ } @ldconfig_folders;
+
+ my $installed = $self->processable->installed;
+
+ my $versioned_name = $item->dirname . $soname;
+ my $versioned_item = $installed->lookup($versioned_name);
+
+ my $unversioned_name = $versioned_name;
+ # libtool "-release" variant
+ $unversioned_name =~ s/-[\d\.]+\.so$/.so/;
+ # determine shlib link name (w/o version)
+ $unversioned_name =~ s/\.so.+$/.so/;
+
+ $self->pointed_hint('lacks-versioned-link-to-shared-library',
+ $item->pointer, $versioned_name)
+ unless defined $versioned_item;
+
+ $self->pointed_hint(
+ 'ldconfig-symlink-referencing-wrong-file',
+ $versioned_item->pointer,'should point to',
+ $versioned_item->link,'instead of',$item->basename
+ )
+ if $versioned_name ne $item->name
+ && defined $versioned_item
+ && $versioned_item->is_symlink
+ && $versioned_item->link ne $item->basename;
+
+ $self->pointed_hint(
+ 'ldconfig-symlink-is-not-a-symlink',
+ $versioned_item->pointer,'should point to',
+ $item->name
+ )
+ if $versioned_name ne $item->name
+ && defined $versioned_item
+ && !$versioned_item->is_symlink;
+
+ # shlib symlink may not exist.
+ # if shlib doesn't _have_ a version, then $unversioned_name and
+ # $item->name will be equal, and it's not a development link,
+ # so don't complain.
+ $self->pointed_hint(
+ 'link-to-shared-library-in-wrong-package',
+ $installed->lookup($unversioned_name)->pointer,
+ $item->name
+ )
+ if $unversioned_name ne $item->name
+ && defined $installed->lookup($unversioned_name);
+
+ # If the shared library is in /lib, we have to look for
+ # the dev symlink in /usr/lib
+ $unversioned_name = "usr/$unversioned_name"
+ unless $item->name =~ m{^usr/};
+
+ my @dev_links;
+ for my $dev_installable (@{$self->development_packages}) {
+ for my $dev_item (@{$dev_installable->installed->sorted_list}) {
+
+ next
+ unless $dev_item->is_symlink;
+
+ next
+ unless $dev_item->name =~ m{^ usr/lib/ }x;
+
+ # try absolute first
+ my $resolved = $installed->resolve_path($dev_item->link);
+
+ # otherwise relative
+ $resolved
+ = $installed->resolve_path($dev_item->dirname . $dev_item->link)
+ unless defined $resolved;
+
+ next
+ unless defined $resolved;
+
+ push(@dev_links, $dev_item)
+ if $resolved->name eq $item->name;
+ }
+ }
+
+ # found -dev package; library needs a symlink
+ $self->pointed_hint('lacks-unversioned-link-to-shared-library',
+ $item->pointer, "example: $unversioned_name")
+ if @{$self->development_packages}
+ && (none { $_->name =~ m{ [.]so $}x } @dev_links);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/MultiArch.pm b/lib/Lintian/Check/Libraries/Shared/MultiArch.pm
new file mode 100644
index 0000000..52c1bc5
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/MultiArch.pm
@@ -0,0 +1,79 @@
+# libraries/shared/multi-arch -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::MultiArch;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has shared_libraries => (is => 'rw', default => sub { [] });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ m{^ [^,]* \b ELF \b }x;
+
+ return
+ unless $item->file_type
+ =~ m{(?: shared [ ] object | pie [ ] executable )}x;
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+ return
+ if none { $item->dirname eq $_ } @ldconfig_folders;
+
+ push(@{$self->shared_libraries}, $item->name);
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint(
+ 'shared-library-is-multi-arch-foreign',
+ (sort +uniq @{$self->shared_libraries})
+ )
+ if @{$self->shared_libraries}
+ && $self->processable->fields->value('Multi-Arch') eq 'foreign';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Obsolete.pm b/lib/Lintian/Check/Libraries/Shared/Obsolete.pm
new file mode 100644
index 0000000..699b70c
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Obsolete.pm
@@ -0,0 +1,56 @@
+# libraries/shared/obsolete -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Mo Zhou
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Obsolete;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^[^,]*\bELF\b/;
+
+ my @needed = @{$item->elf->{NEEDED} // []};
+ my @obsolete = grep { /^libcblas\.so\.\d/ } @needed;
+
+ $self->pointed_hint('linked-with-obsolete-library', $item->pointer, $_)
+ for @obsolete;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Relocation.pm b/lib/Lintian/Check/Libraries/Shared/Relocation.pm
new file mode 100644
index 0000000..8c3dac9
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Relocation.pm
@@ -0,0 +1,58 @@
+# libraries/shared/relocation -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Relocation;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # shared library
+ return
+ unless @{$item->elf->{SONAME} // [] };
+
+ # Now that we're sure this is really a shared library, report on
+ # non-PIC problems.
+ $self->pointed_hint('specific-address-in-shared-library', $item->pointer)
+ if $item->elf->{TEXTREL};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Soname.pm b/lib/Lintian/Check/Libraries/Shared/Soname.pm
new file mode 100644
index 0000000..9887e3b
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Soname.pm
@@ -0,0 +1,123 @@
+# libraries/shared/soname -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Soname;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+has DEB_HOST_MULTIARCH => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->architectures->deb_host_multiarch;
+ }
+);
+
+sub installable {
+ my ($self) = @_;
+
+ return
+ if $self->processable->type eq 'udeb';
+
+ my $architecture = $self->processable->fields->value('Architecture');
+ my $multiarch_component = $self->DEB_HOST_MULTIARCH->{$architecture};
+
+ my @common_folders = qw{lib usr/lib};
+ push(@common_folders, map { "$_/$multiarch_component" } @common_folders)
+ if length $multiarch_component;
+
+ my @duplicated;
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ # For the package naming check, filter out SONAMEs where all the
+ # files are at paths other than /lib, /usr/lib and /usr/lib/<MA-DIR>.
+ # This avoids false positives with plugins like Apache modules,
+ # which may have their own SONAMEs but which don't matter for the
+ # purposes of this check.
+ next
+ if none { $item->dirname eq $_ . $SLASH } @common_folders;
+
+ # Also filter out nsswitch modules
+ next
+ if $item->basename =~ m{^ libnss_[^.]+\.so(?:\.\d+) $}x;
+
+ push(@duplicated, @{$item->elf->{SONAME} // []});
+ }
+
+ my @sonames = uniq @duplicated;
+
+ # try to strip transition strings
+ my $shortened_name = $self->processable->name;
+ $shortened_name =~ s/c102\b//;
+ $shortened_name =~ s/c2a?\b//;
+ $shortened_name =~ s/\dg$//;
+ $shortened_name =~ s/gf$//;
+ $shortened_name =~ s/v[5-6]$//; # GCC-5 / libstdc++6 C11 ABI breakage
+ $shortened_name =~ s/-udeb$//;
+ $shortened_name =~ s/^lib64/lib/;
+
+ my $match_found = 0;
+ for my $soname (@sonames) {
+
+ $soname =~ s/ ([0-9]) [.]so[.] /$1-/x;
+ $soname =~ s/ [.]so (?:[.]|\z) //x;
+ $soname =~ s/_/-/g;
+
+ my $lowercase = lc $soname;
+
+ $match_found = any { $lowercase eq $_ }
+ ($self->processable->name, $shortened_name);
+
+ last
+ if $match_found;
+ }
+
+ $self->hint('package-name-doesnt-match-sonames',
+ join($SPACE, sort @sonames))
+ if @sonames && !$match_found;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm b/lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm
new file mode 100644
index 0000000..a01a878
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm
@@ -0,0 +1,73 @@
+# libraries/shared/soname/missing -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Soname::Missing;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ m{^ [^,]* \b ELF \b }x;
+
+ return
+ unless $item->file_type
+ =~ m{(?: shared [ ] object | pie [ ] executable )}x;
+
+ # does not have SONAME
+ return
+ if @{$item->elf->{SONAME} // [] };
+
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+ return
+ if none { $item->dirname eq $_ } @ldconfig_folders;
+
+ # disregard executables
+ $self->pointed_hint('sharedobject-in-library-directory-missing-soname',
+ $item->pointer)
+ if !$item->is_executable
+ || !defined $item->elf->{DEBUG}
+ || $item->name =~ / [.]so (?: [.] | $ ) /msx;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Stack.pm b/lib/Lintian/Check/Libraries/Shared/Stack.pm
new file mode 100644
index 0000000..f3e1d03
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Stack.pm
@@ -0,0 +1,69 @@
+# libraries/shared/stack -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Stack;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # shared library
+ return
+ unless @{$item->elf->{SONAME} // [] };
+
+ $self->pointed_hint('shared-library-lacks-stack-section',$item->pointer)
+ if $self->processable->fields->declares('Architecture')
+ && !exists $item->elf->{PH}{STACK};
+
+ $self->pointed_hint('executable-stack-in-shared-library', $item->pointer)
+ if exists $item->elf->{PH}{STACK}
+ && $item->elf->{PH}{STACK}{flags} ne 'rw-'
+ # Once the following line is removed again, please also remove
+ # the Test-Architectures line in
+ # t/recipes/checks/libraries/shared/stack/shared-libs-exec-stack/eval/desc
+ # and the MIPS-related notes in
+ # tags/e/executable-stack-in-shared-library.tag. See
+ # https://bugs.debian.org/1025436 and
+ # https://bugs.debian.org/1022787 for details
+ && $self->processable->fields->value('Architecture') !~ /mips/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm b/lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm
new file mode 100644
index 0000000..66f5961
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm
@@ -0,0 +1,131 @@
+# libraries/shared/trigger/ldconfig -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Shared::Trigger::Ldconfig;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has soname_by_filename => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %soname_by_filename;
+ for my $item (@{$self->processable->installed->sorted_list}) {
+
+ $soname_by_filename{$item->name}= $item->elf->{SONAME}[0]
+ if exists $item->elf->{SONAME};
+ }
+
+ return \%soname_by_filename;
+ }
+);
+
+has must_call_ldconfig => (is => 'rw', default => sub { [] });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ my $resolved_name = $item->name;
+ $resolved_name = $item->link_normalized
+ if length $item->link;
+
+ # Installed in a directory controlled by the dynamic
+ # linker? We have to strip off directories named for
+ # hardware capabilities.
+ # yes! so postinst must call ldconfig
+ push(@{$self->must_call_ldconfig}, $resolved_name)
+ if exists $self->soname_by_filename->{$resolved_name}
+ && $self->needs_ldconfig($item);
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ # determine if the package had an ldconfig trigger
+ my $triggers = $self->processable->control->resolve_path('triggers');
+
+ my $we_trigger_ldconfig = 0;
+ $we_trigger_ldconfig = 1
+ if defined $triggers
+ && $triggers->decoded_utf8
+ =~ /^ \s* activate-noawait \s+ ldconfig \s* $/mx;
+
+ $self->hint('package-has-unnecessary-activation-of-ldconfig-trigger')
+ if !@{$self->must_call_ldconfig}
+ && $we_trigger_ldconfig
+ && $self->processable->type ne 'udeb';
+
+ $self->hint('lacks-ldconfig-trigger',
+ (sort +uniq @{$self->must_call_ldconfig}))
+ if @{$self->must_call_ldconfig}
+ && !$we_trigger_ldconfig
+ && $self->processable->type ne 'udeb';
+
+ return;
+}
+
+sub needs_ldconfig {
+ my ($self, $item) = @_;
+
+ # Libraries that should only be used in the presence of certain capabilities
+ # may be located in subdirectories of the standard ldconfig search path with
+ # one of the following names.
+ my $HWCAP_DIRS = $self->data->load('shared-libs/hwcap-dirs');
+ my @ldconfig_folders = @{$self->data->architectures->ldconfig_folders};
+
+ my $dirname = $item->dirname;
+ my $encapsulator;
+ do {
+ $dirname =~ s{ ([^/]+) / $}{}x;
+ $encapsulator = $1;
+
+ } while ($encapsulator && $HWCAP_DIRS->recognizes($encapsulator));
+
+ $dirname .= "$encapsulator/" if $encapsulator;
+
+ # yes! so postinst must call ldconfig
+ return 1
+ if any { $dirname eq $_ } @ldconfig_folders;
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Static.pm b/lib/Lintian/Check/Libraries/Static.pm
new file mode 100644
index 0000000..72c8b97
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Static.pm
@@ -0,0 +1,121 @@
+# libraries/static -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Static;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any none uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x;
+
+ my @unstripped_members;
+ my %stripped_sections_by_member;
+
+ for my $member_name (keys %{$item->elf_by_member}) {
+
+ my $member_elf = $item->elf_by_member->{$member_name};
+
+ my @elf_sections = values %{$member_elf->{'SECTION-HEADERS'}};
+ my @have_section_names = map { $_->name } @elf_sections;
+
+ # These are the ones file(1) looks for. The ".zdebug_info" being the
+ # compressed version of .debug_info.
+ # - Technically, file(1) also looks for .symtab, but that is apparently
+ # not strippable for static libs. Accordingly, it is omitted below.
+ my @KNOWN_DEBUG_SECTION_NAMES = qw{.debug_info .zdebug_info};
+ my $lc_debug = List::Compare->new(\@have_section_names,
+ \@KNOWN_DEBUG_SECTION_NAMES);
+
+ my @have_debug_sections = $lc_debug->get_intersection;
+
+ if (@have_debug_sections) {
+
+ push(@unstripped_members, $member_name);
+ next;
+ }
+
+ my @KNOWN_STRIPPED_SECTION_NAMES = qw{.note .comment};
+ my $lc_stripped = List::Compare->new(\@have_section_names,
+ \@KNOWN_STRIPPED_SECTION_NAMES);
+
+ my @have_stripped_sections = $lc_stripped->get_intersection;
+
+ $stripped_sections_by_member{$member_name} //= [];
+ push(
+ @{$stripped_sections_by_member{$member_name}},
+ @have_stripped_sections
+ );
+ }
+
+ $self->pointed_hint('unstripped-static-library', $item->pointer,
+ $LEFT_PARENTHESIS
+ . join($SPACE, sort +uniq @unstripped_members)
+ . $RIGHT_PARENTHESIS)
+ if @unstripped_members
+ && $item->name !~ m{ _g [.]a $}x;
+
+ # "libfoo_g.a" is usually a "debug" library, so ignore
+ # unneeded sections in those.
+ for my $member (keys %stripped_sections_by_member) {
+
+ $self->pointed_hint(
+ 'static-library-has-unneeded-sections',
+ $item->pointer,
+ "($member)",
+ join($SPACE, sort +uniq @{$stripped_sections_by_member{$member}})
+ )
+ if @{$stripped_sections_by_member{$member}}
+ && $item->name !~ m{ _g [.]a $}x;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm b/lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm
new file mode 100644
index 0000000..04e65e8
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm
@@ -0,0 +1,70 @@
+# libraries/static/link-time-optimization -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Static::LinkTimeOptimization;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # not sure if that captures everything GHC, or too much
+ return
+ if $item->name =~ m{^ usr/lib/ghc/ }x;
+
+ return
+ unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x;
+
+ for my $member_name (keys %{$item->elf_by_member}) {
+
+ my $member_elf = $item->elf_by_member->{$member_name};
+
+ my @elf_sections = values %{$member_elf->{'SECTION-HEADERS'}};
+ my @section_names = map { $_->name } @elf_sections;
+
+ my @lto_section_names = grep { m{^ [.]gnu[.]lto }x } @section_names;
+
+ $self->pointed_hint('static-link-time-optimization',
+ $item->pointer, $member_name)
+ if @lto_section_names;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Static/Name.pm b/lib/Lintian/Check/Libraries/Static/Name.pm
new file mode 100644
index 0000000..a4c47d1
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Static/Name.pm
@@ -0,0 +1,61 @@
+# libraries/static/name -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Static::Name;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x;
+
+ my $shortened = $item->name;
+
+ if ($shortened =~ s{ _s[.]a $}{.a}x) {
+
+ $self->pointed_hint('odd-static-library-name', $item->pointer)
+ unless defined $self->processable->installed->lookup($shortened);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Libraries/Static/NoCode.pm b/lib/Lintian/Check/Libraries/Static/NoCode.pm
new file mode 100644
index 0000000..0d2415a
--- /dev/null
+++ b/lib/Lintian/Check/Libraries/Static/NoCode.pm
@@ -0,0 +1,95 @@
+# libraries/static/no-code -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Libraries::Static::NoCode;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any uniq);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ # not sure if that captures everything GHC, or too much
+ return
+ if $item->name =~ m{^ usr/lib/ghc/ }x;
+
+ return
+ unless $item->file_type =~ m{ \b current [ ] ar [ ] archive \b }x;
+
+ my @codeful_members;
+ for my $member_name (keys %{$item->elf_by_member}) {
+
+ my $member_elf = $item->elf_by_member->{$member_name};
+
+ my @elf_sections = values %{$member_elf->{'SECTION-HEADERS'}};
+ my @sections_with_size = grep { $_->size > 0 } @elf_sections;
+
+ my @names_with_size = map { $_->name } @sections_with_size;
+
+ my @KNOWN_ARRAY_SECTIONS = qw{.preinit_array .init_array .fini_array};
+ my $lc_array
+ = List::Compare->new(\@names_with_size, \@KNOWN_ARRAY_SECTIONS);
+
+ my @have_array_sections = $lc_array->get_intersection;
+
+# adapted from https://github.com/rpm-software-management/rpmlint/blob/main/rpmlint/checks/BinariesCheck.py#L242-L249
+ my $has_code = 0;
+
+ $has_code = 1
+ if any { m{^ [.]text }x } @names_with_size;
+
+ $has_code = 1
+ if any { m{^ [.]data }x } @names_with_size;
+
+ $has_code = 1
+ if @have_array_sections;
+
+ push(@codeful_members, $member_name)
+ if $has_code;
+ }
+
+ $self->pointed_hint('no-code-sections', $item->pointer)
+ unless @codeful_members;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Linda.pm b/lib/Lintian/Check/Linda.pm
new file mode 100644
index 0000000..f7dcca8
--- /dev/null
+++ b/lib/Lintian/Check/Linda.pm
@@ -0,0 +1,47 @@
+# linda -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Linda;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('package-contains-linda-override', $item->pointer)
+ if $item->name =~ m{^usr/share/linda/overrides/\S+};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Lintian.pm b/lib/Lintian/Check/Lintian.pm
new file mode 100644
index 0000000..abfcccc
--- /dev/null
+++ b/lib/Lintian/Check/Lintian.pm
@@ -0,0 +1,38 @@
+# Lintian -- lintian check script (rewrite) -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Lintian;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Mailcap.pm b/lib/Lintian/Check/Mailcap.pm
new file mode 100644
index 0000000..2588d43
--- /dev/null
+++ b/lib/Lintian/Check/Mailcap.pm
@@ -0,0 +1,108 @@
+# mailcap -- lintian check script -*- perl -*-
+
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Mailcap;
+
+use v5.20;
+use warnings;
+use utf8;
+use autodie qw(open);
+
+use Const::Fast;
+use List::SomeUtils qw(uniq);
+use Text::Balanced qw(extract_delimited extract_multiple);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^usr/lib/mime/packages/};
+
+ return
+ unless $item->is_file && $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path);
+
+ my @continuation;
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ unless (@continuation) {
+ # skip blank lines
+ next
+ if $line =~ /^\s*$/;
+
+ # skip comments
+ next
+ if $line =~ /^\s*#/;
+ }
+
+ # continuation line
+ if ($line =~ s/\\$//) {
+ push(@continuation, {string => $line, position => $position});
+ next;
+ }
+
+ push(@continuation, {string => $line, position => $position});
+
+ my $assembled = $EMPTY;
+ $assembled .= $_->{string} for @continuation;
+
+ my $start_position = $continuation[0]->{position};
+
+ my @quoted
+ = extract_multiple($assembled,
+ [sub { extract_delimited($_[0], q{"'}, '[^\'"]*') }],
+ undef, 1);
+
+ my @placeholders = uniq grep { /\%s/ } @quoted;
+
+ $self->pointed_hint(
+ 'quoted-placeholder-in-mailcap-entry',
+ $item->pointer($start_position),
+ @placeholders
+ )if @placeholders;
+
+ @continuation = ();
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Adduser.pm b/lib/Lintian/Check/MaintainerScripts/Adduser.pm
new file mode 100644
index 0000000..f8bbea4
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Adduser.pm
@@ -0,0 +1,96 @@
+# maintainer_scripts::adduser -- lintian check script -*- perl -*-
+
+# Copyright (C) 2020 Topi Miettinen
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Adduser;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ # get maintainer scripts
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $continuation = undef;
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ # merge lines ending with '\'
+ if (defined $continuation) {
+ $line = $continuation . $line;
+ $continuation = undef;
+ }
+
+ if ($line =~ /\\$/) {
+ $continuation = $line;
+ $continuation =~ s/\\$/ /;
+ next;
+ }
+
+ # trim right
+ $line =~ s/\s+$//;
+
+ # skip empty lines
+ next
+ if $line =~ /^\s*$/;
+
+ # skip comments
+ next
+ if $line =~ /^[#\n]/;
+
+ $self->pointed_hint('adduser-with-home-var-run',
+ $item->pointer($position))
+ if $line =~ /adduser .*--home +\/var\/run/;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/AncientVersion.pm b/lib/Lintian/Check/MaintainerScripts/AncientVersion.pm
new file mode 100644
index 0000000..9fac1c5
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/AncientVersion.pm
@@ -0,0 +1,180 @@
+# maintainer-scripts/ancient-version -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::AncientVersion;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use POSIX qw(strftime);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# date --date="Sat, 14 Aug 2021 17:41:41 -0400" +%s
+# https://lists.debian.org/debian-announce/2021/msg00003.html
+const my $OLDSTABLE_RELEASE_EPOCH => 1_628_977_301;
+
+# When detecting commands inside shell scripts, use this regex to match the
+# beginning of the command rather than checking whether the command is at the
+# beginning of a line.
+const my $LEADING_PATTERN=>
+'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
+const my $LEADING_REGEX => qr/$LEADING_PATTERN/;
+
+has old_versions => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %old_versions;
+ for my $entry (
+ $self->processable->changelog
+ ? @{$self->processable->changelog->entries}
+ : ()
+ ) {
+ my $timestamp = $entry->Timestamp // $OLDSTABLE_RELEASE_EPOCH;
+ $old_versions{$entry->Version} = $timestamp
+ if $timestamp < $OLDSTABLE_RELEASE_EPOCH;
+ }
+
+ return \%old_versions;
+ }
+);
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ for my $old_version (keys %{$self->old_versions}) {
+
+ next
+ if $old_version =~ /^\d+$/;
+
+ if ($line
+ =~m{$LEADING_REGEX(?:/usr/bin/)?dpkg\s+--compare-versions\s+.*\b\Q$old_version\E(?!\.)\b}
+ ) {
+ my $date
+ = strftime('%Y-%m-%d',
+ gmtime $self->old_versions->{$old_version});
+ my $epoch
+ = strftime('%Y-%m-%d', gmtime $OLDSTABLE_RELEASE_EPOCH);
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint(
+ 'maintainer-script-supports-ancient-package-version',
+ $pointer, $old_version,"($date < $epoch)",
+ );
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Diversion.pm b/lib/Lintian/Check/MaintainerScripts/Diversion.pm
new file mode 100644
index 0000000..e786422
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Diversion.pm
@@ -0,0 +1,369 @@
+# maintainer-scripts/diversion -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Diversion;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# When detecting commands inside shell scripts, use this regex to match the
+# beginning of the command rather than checking whether the command is at the
+# beginning of a line.
+const my $LEADING_PATTERN=>
+'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
+const my $LEADING_REGEX => qr/$LEADING_PATTERN/;
+
+has added_diversions => (is => 'rw', default => sub { {} });
+has removed_diversions => (is => 'rw', default => sub { {} });
+has expand_diversions => (is => 'rw', default => 0);
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ if ( $line =~ m{$LEADING_REGEX(?:/usr/sbin/)?dpkg-divert\s}
+ && $line !~ /--(?:help|list|truename|version)/) {
+
+ $self->pointed_hint('package-uses-local-diversion',$pointer)
+ if $line =~ /--local/;
+
+ my $mode = $line =~ /--remove/ ? 'remove' : 'add';
+
+ my ($divert) = ($line =~ /dpkg-divert\s*(.*)$/);
+
+ $divert =~ s{\s*(?:\$[{]?[\w:=-]+[}]?)*\s*
+ # options without arguments
+ --(?:add|quiet|remove|rename|no-rename|test|local
+ # options with arguments
+ |(?:admindir|divert|package) \s+ \S+)
+ \s*}{}gxsm;
+
+ # Remove unpaired opening or closing parenthesis
+ 1 while ($divert =~ m/\G.*?\(.+?\)/gc);
+ $divert =~ s/\G(.*?)[()]/$1/;
+ pos($divert) = undef;
+
+ # Remove unpaired opening or closing braces
+ 1 while ($divert =~ m/\G.*?{.+?}/gc);
+ $divert =~ s/\G(.*?)[{}]/$1/;
+ pos($divert) = undef;
+
+ # position after the last pair of quotation marks, if any
+ 1 while ($divert =~ m/\G.*?(["']).+?\1/gc);
+
+ # Strip anything matching and after '&&', '||', ';', or '>'
+ # this is safe only after we are positioned after the last pair
+ # of quotation marks
+ $divert =~ s/\G.+?\K(?: && | \|\| | ; | \d*> ).*$//x;
+ pos($divert) = undef;
+
+ # Remove quotation marks, they affect:
+ # * our var to regex trick
+ # * stripping the initial slash if the path was quoted
+ $divert =~ s/[\"\']//g;
+
+ # remove the leading / because it's not in the index hash
+ $divert =~ s{^/}{};
+
+ # trim both ends
+ $divert =~ s/^\s+|\s+$//g;
+
+ $divert = quotemeta($divert);
+
+ # For now just replace variables, they will later be normalised
+ $self->expand_diversions(1)
+ if $divert =~ s/\\\$\w+/.+/g;
+
+ $self->expand_diversions(1)
+ if $divert =~ s/\\\$\\[{]\w+.*?\\[}]/.+/g;
+
+ # handle $() the same way:
+ $self->expand_diversions(1)
+ if $divert =~ s/\\\$\\\(.+?\\\)/.+/g;
+
+ my %diversion;
+ $diversion{script} = $item;
+ $diversion{position} = $position;
+
+ $self->added_diversions->{$divert} = \%diversion
+ if $mode eq 'add';
+
+ push(@{$self->removed_diversions->{$divert}}, \%diversion)
+ if $mode eq 'remove';
+
+ die encode_utf8("mode has unknown value: $mode")
+ if none { $mode eq $_ } qw{add remove};
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ # If any of the maintainer scripts used a variable in the file or
+ # diversion name normalise them all
+ if ($self->expand_diversions) {
+
+ for my $divert (
+ keys %{$self->removed_diversions},
+ keys %{$self->added_diversions}
+ ) {
+
+ # if a wider regex was found, the entries might no longer be there
+ next
+ unless exists $self->removed_diversions->{$divert}
+ || exists $self->added_diversions->{$divert};
+
+ my $widerrx = $divert;
+ my $wider = $widerrx;
+ $wider =~ s/\\//g;
+
+ # find the widest regex:
+ my @matches = grep {
+ my $lrx = $_;
+ my $l = $lrx;
+ $l =~ s/\\//g;
+
+ if ($wider =~ m/^$lrx$/) {
+ $widerrx = $lrx;
+ $wider = $l;
+ 1;
+ } elsif ($l =~ m/^$widerrx$/) {
+ 1;
+ } else {
+ 0;
+ }
+ } (
+ keys %{$self->removed_diversions},
+ keys %{$self->added_diversions}
+ );
+
+ # replace all the occurrences with the widest regex:
+ for my $k (@matches) {
+
+ next
+ if $k eq $widerrx;
+
+ if (exists $self->removed_diversions->{$k}) {
+
+ $self->removed_diversions->{$widerrx}
+ = $self->removed_diversions->{$k};
+
+ delete $self->removed_diversions->{$k};
+ }
+
+ if (exists $self->added_diversions->{$k}) {
+
+ $self->added_diversions->{$widerrx}
+ = $self->added_diversions->{$k};
+
+ delete $self->added_diversions->{$k};
+ }
+ }
+ }
+ }
+
+ for my $divert (keys %{$self->removed_diversions}) {
+
+ if (exists $self->added_diversions->{$divert}) {
+ # just mark the entry, because a --remove might
+ # happen in two branches in the script, i.e. we
+ # see it twice, which is not a bug
+ $self->added_diversions->{$divert}{removed} = 1;
+
+ } else {
+
+ for my $item (@{$self->removed_diversions->{$divert}}) {
+
+ my $script = $item->{script};
+ my $position = $item->{position};
+
+ next
+ unless $script->name eq 'postrm';
+
+ # Allow preinst and postinst to remove diversions the
+ # package doesn't add to clean up after previous
+ # versions of the package.
+
+ my $unquoted = unquote($divert, $self->expand_diversions);
+
+ my $pointer = $script->pointer($position);
+
+ $self->pointed_hint('remove-of-unknown-diversion', $pointer,
+ $unquoted);
+ }
+ }
+ }
+
+ for my $divert (keys %{$self->added_diversions}) {
+
+ my $script = $self->added_diversions->{$divert}{script};
+ my $position = $self->added_diversions->{$divert}{position};
+
+ my $pointer = $script->pointer($script);
+ $pointer->position($position);
+
+ my $divertrx = $divert;
+ my $unquoted = unquote($divert, $self->expand_diversions);
+
+ $self->pointed_hint('orphaned-diversion', $pointer, $unquoted)
+ unless exists $self->added_diversions->{$divertrx}{removed};
+
+ # Handle man page diversions somewhat specially. We may
+ # divert away a man page in one section without replacing that
+ # same file, since we're installing a man page in a different
+ # section. An example is diverting a man page in section 1
+ # and replacing it with one in section 1p (such as
+ # libmodule-corelist-perl at the time of this writing).
+ #
+ # Deal with this by turning all man page diversions into
+ # wildcard expressions instead that match everything in the
+ # same numeric section so that they'll match the files shipped
+ # in the package.
+ if ($divertrx =~ m{^(usr\\/share\\/man\\/\S+\\/.*\\\.\d)\w*(\\\.gz\z)})
+ {
+ $divertrx = "$1.*$2";
+ $self->expand_diversions(1);
+ }
+
+ if ($self->expand_diversions) {
+
+ $self->pointed_hint('diversion-for-unknown-file', $pointer,
+ $unquoted)
+ unless (any { /$divertrx/ }
+ @{$self->processable->installed->sorted_list});
+
+ } else {
+ $self->pointed_hint('diversion-for-unknown-file', $pointer,
+ $unquoted)
+ unless $self->processable->installed->lookup($unquoted);
+ }
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+sub unquote {
+ my ($string, $replace_regex) = @_;
+
+ $string =~ s{\\}{}g;
+
+ $string =~ s{\.\+}{*}g
+ if $replace_regex;
+
+ return $string;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm b/lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm
new file mode 100644
index 0000000..6b8347c
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm
@@ -0,0 +1,148 @@
+# maintainer-scripts/dpkg-statoverride -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::DpkgStatoverride;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# When detecting commands inside shell scripts, use this regex to match the
+# beginning of the command rather than checking whether the command is at the
+# beginning of a line.
+const my $LEADING_PATTERN=>
+'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
+const my $LEADING_REGEX => qr/$LEADING_PATTERN/;
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $saw_statoverride_list = 0;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ if ($line =~ m{$LEADING_REGEX(?:/usr/bin/)?dpkg-statoverride\s}) {
+
+ $saw_statoverride_list = 1
+ if $line =~ /--list/;
+
+ if ($line =~ /--add/) {
+
+ $self->pointed_hint('unconditional-use-of-dpkg-statoverride',
+ $pointer)
+ unless $saw_statoverride_list;
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Empty.pm b/lib/Lintian/Check/MaintainerScripts/Empty.pm
new file mode 100644
index 0000000..298eb0a
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Empty.pm
@@ -0,0 +1,144 @@
+# maintainer-scripts/empty -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Empty;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $has_code = 0;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ # Don't consider the standard dh-make boilerplate to be code. This
+ # means ignoring the framework of a case statement, the labels, the
+ # echo complaining about unknown arguments, and an exit.
+ if ( $line !~ /^\s*set\s+-\w+\s*$/
+ && $line !~ /^\s*case\s+\"?\$1\"?\s+in\s*$/
+ && $line !~ /^\s*(?:[a-z|-]+|\*)\)\s*$/
+ && $line !~ /^\s*[:;]+\s*$/
+ && $line !~ /^\s*echo\s+\"[^\"]+\"(?:\s*>&2)?\s*$/
+ && $line !~ /^\s*esac\s*$/
+ && $line !~ /^\s*exit\s+\d+\s*$/) {
+
+ $has_code = 1;
+ last;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ $self->pointed_hint('maintainer-script-empty', $item->pointer)
+ unless $has_code;
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Generated.pm b/lib/Lintian/Check/MaintainerScripts/Generated.pm
new file mode 100644
index 0000000..bf00910
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Generated.pm
@@ -0,0 +1,85 @@
+# maintainer-scripts/generated -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Generated;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(uniq);
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ my @tools_seen;
+
+ # get maintainer scripts
+ my @control
+ = grep { $_->is_maintainer_script }
+ @{$self->processable->control->sorted_list};
+
+ for my $file (@control) {
+
+ my $hashbang = $file->hashbang;
+ next
+ unless length $hashbang;
+
+ next
+ unless $file->is_open_ok;
+
+ my @lines = path($file->unpacked_path)->lines;
+
+ # scan contents
+ for (@lines) {
+
+ # skip empty lines
+ next
+ if /^\s*$/;
+
+ if (/^# Automatically added by (\S+)\s*$/) {
+ my $tool = $1;
+# remove trailing ":" from dh_python
+# https://sources.debian.org/src/dh-python/4.20191017/dhpython/debhelper.py/#L200
+ $tool =~ s/:\s*$//g;
+ push(@tools_seen, $tool);
+ }
+ }
+ }
+
+ $self->hint('debhelper-autoscript-in-maintainer-scripts', $_)
+ for uniq @tools_seen;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm b/lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm
new file mode 100644
index 0000000..ef87c40
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm
@@ -0,0 +1,183 @@
+# maintainer-scripts/helper/dpkg -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Helper::Dpkg;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# When detecting commands inside shell scripts, use this regex to match the
+# beginning of the command rather than checking whether the command is at the
+# beginning of a line.
+const my $LEADING_PATTERN=>
+'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
+const my $LEADING_REGEX => qr/$LEADING_PATTERN/;
+
+has seen_helper_commands => (is => 'rw', default => sub { {} });
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ if ($line
+ =~ m{$LEADING_REGEX(?:/usr/bin/)?dpkg-maintscript-helper\s(\S+)}){
+
+ my $command = $1;
+
+ $self->seen_helper_commands->{$command} //= [];
+ push(@{$self->seen_helper_commands->{$command}}, $item->name);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ for my $command (keys %{$self->seen_helper_commands}) {
+
+ # entering the loop means there is at least one member
+ my @have = @{$self->seen_helper_commands->{$command} // [] };
+ next
+ unless @have;
+
+ # dpkg-maintscript-helper(1) recommends the snippets are in all
+ # maintainer scripts but they are not strictly required in prerm.
+ my @wanted = qw{preinst postinst postrm};
+
+ my $lc = List::Compare->new(\@wanted, \@have);
+
+ my @missing = $lc->get_Lonly;
+
+ for my $name (@missing) {
+
+ my $item = $self->processable->control->lookup($name);
+
+ if (defined $item) {
+
+ $self->pointed_hint('missing-call-to-dpkg-maintscript-helper',
+ $item->pointer, $command);
+
+ } else {
+ # file does not exist
+ $self->hint('missing-call-to-dpkg-maintscript-helper',
+ $command, "[$name]");
+ }
+ }
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Killall.pm b/lib/Lintian/Check/MaintainerScripts/Killall.pm
new file mode 100644
index 0000000..2c3dd09
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Killall.pm
@@ -0,0 +1,131 @@
+# maintainer-scripts/killall -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Killall;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ $self->pointed_hint('killall-is-dangerous', $pointer)
+ if $line =~ /^\s*killall(?:\s|\z)/;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Ldconfig.pm b/lib/Lintian/Check/MaintainerScripts/Ldconfig.pm
new file mode 100644
index 0000000..22e64d2
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Ldconfig.pm
@@ -0,0 +1,60 @@
+# maintainer-scripts/ldconfig -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Ldconfig;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless $item->decoded_utf8 =~ /^ [^\#]* \b ldconfig \b /mx;
+
+ $self->pointed_hint('udeb-postinst-calls-ldconfig', $item->pointer)
+ if $item->name eq 'postinst'
+ && $self->processable->type eq 'udeb';
+
+ $self->pointed_hint('maintscript-calls-ldconfig', $item->pointer)
+ if $item->name ne 'postinst'
+ || $self->processable->type ne 'udeb';
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Mknod.pm b/lib/Lintian/Check/MaintainerScripts/Mknod.pm
new file mode 100644
index 0000000..e7269ea
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Mknod.pm
@@ -0,0 +1,131 @@
+# maintainer-scripts/mknod -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Mknod;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ $self->pointed_hint('mknod-in-maintainer-script', $pointer)
+ if $line =~ /^\s*mknod(?:\s|\z)/ && $line !~ /\sp\s/;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/Systemctl.pm b/lib/Lintian/Check/MaintainerScripts/Systemctl.pm
new file mode 100644
index 0000000..c5e1654
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/Systemctl.pm
@@ -0,0 +1,76 @@
+# masitainer-scripts/systemctl -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2013 Michael Stapelberg
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# based on the apache2 checks file by:
+# Copyright (C) 2012 Arno Toell
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::Systemctl;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ # look only at shell scripts
+ return
+ unless $item->hashbang =~ /^\S*sh\b/;
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ if $line =~ /^#/;
+
+ my $pointer = $item->pointer($position);
+
+ # systemctl should not be called in maintainer scripts at all,
+ # except for systemctl daemon-reload calls.
+ $self->pointed_hint('maintainer-script-calls-systemctl', $pointer)
+ if $line =~ /^(?:.+;)?\s*systemctl\b/
+ && $line !~ /daemon-reload/;
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm b/lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm
new file mode 100644
index 0000000..f6d1164
--- /dev/null
+++ b/lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm
@@ -0,0 +1,144 @@
+# maintainer-scripts/temporary-files -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::MaintainerScripts::TemporaryFiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ if ($line =~ m{ \W ( (?:/var)?/tmp | \$TMPDIR /[^)\]\}\s]+ ) }x) {
+
+ my $indicator = $1;
+
+ $self->pointed_hint(
+ 'possibly-insecure-handling-of-tmp-files-in-maintainer-script',
+ $pointer,
+ $indicator
+ )
+ if $line !~ /\bmks?temp\b/
+ && $line !~ /\btempfile\b/
+ && $line !~ /\bmkdir\b/
+ && $line !~ /\bXXXXXX\b/
+ && $line !~ /\$RANDOM/;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Md5sums.pm b/lib/Lintian/Check/Md5sums.pm
new file mode 100644
index 0000000..c62d9cd
--- /dev/null
+++ b/lib/Lintian/Check/Md5sums.pm
@@ -0,0 +1,133 @@
+# md5sums -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2020 Felix Lechner
+# Copyright (C) 2018, 2020 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Md5sums;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::Compare;
+use Path::Tiny;
+
+use Lintian::Util qw(read_md5sums drop_relative_prefix);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has only_conffiles => (is => 'rw', default => 1);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # check if package contains non-conffiles
+ # debhelper doesn't create entries in md5sums
+ # for conffiles since this information would
+ # be redundant
+
+ # Skip non-files, they will not appear in the md5sums file
+ return
+ unless $item->is_regular_file;
+
+ $self->only_conffiles(0)
+ unless $self->processable->declared_conffiles->is_known($item->name);
+
+ return;
+}
+
+sub binary {
+ my ($self) = @_;
+
+ my $control = $self->processable->control->lookup('md5sums');
+ unless (defined $control) {
+
+ # ignore if package contains no files
+ return
+ unless @{$self->processable->installed->sorted_list};
+
+ $self->hint('no-md5sums-control-file')
+ unless $self->only_conffiles;
+
+ return;
+ }
+
+ # The md5sums file should not be a symlink. If it is, the best
+ # we can do is to leave it alone.
+ return
+ if $control->is_symlink;
+
+ return
+ unless $control->is_open_ok;
+
+ # Is it empty? Then skip it. Tag will be issued by control-files
+ return
+ if $control->size == 0;
+
+ my $text = $control->bytes;
+
+ my ($md5sums, $errors) = read_md5sums($text);
+
+ $self->pointed_hint('malformed-md5sums-control-file',$control->pointer, $_)
+ for @{$errors};
+
+ my %noprefix
+ = map { drop_relative_prefix($_) => $md5sums->{$_} } keys %{$md5sums};
+
+ my @listed = keys %noprefix;
+ my @found
+ = grep { $_->is_file} @{$self->processable->installed->sorted_list};
+
+ my $lc = List::Compare->new(\@listed, \@found);
+
+ # find files that should exist but do not
+ $self->pointed_hint('md5sums-lists-nonexistent-file',$control->pointer, $_)
+ for $lc->get_Lonly;
+
+ # find files that should be listed but are not
+ for my $name ($lc->get_Ronly) {
+
+ $self->pointed_hint('file-missing-in-md5sums', $control->pointer,$name)
+ unless $self->processable->declared_conffiles->is_known($name)
+ || $name =~ m{^var/lib/[ai]spell/.};
+ }
+
+ # checksum should match for common files
+ for my $name ($lc->get_intersection) {
+
+ my $item = $self->processable->installed->lookup($name);
+
+ $self->pointed_hint('md5sum-mismatch', $control->pointer, $name)
+ unless $item->md5sum eq $noprefix{$name};
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/MenuFormat.pm b/lib/Lintian/Check/MenuFormat.pm
new file mode 100644
index 0000000..c9d40a8
--- /dev/null
+++ b/lib/Lintian/Check/MenuFormat.pm
@@ -0,0 +1,907 @@
+# menu format -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 by Joey Hess
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+# This script also checks desktop entries, since they share quite a bit of
+# code. At some point, it would make sense to try to refactor this so that
+# shared code is in libraries.
+#
+# Further things that the desktop file validation should be checking:
+#
+# - Encoding of the file should be UTF-8.
+# - Additional Categories should be associated with Main Categories.
+# - List entries (MimeType, Categories) should end with a semicolon.
+# - Check for GNOME/GTK/X11/etc. dependencies and require the relevant
+# Additional Category to be present.
+# - Check all the escape characters supported by Exec.
+# - Review desktop-file-validate to see what else we're missing.
+
+package Lintian::Check::MenuFormat;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::SomeUtils qw(any first_value);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+const my $MAXIMUM_SIZE_STANDARD_ICON => 32;
+const my $MAXIMUM_SIZE_32X32_ICON => 32;
+const my $MAXIMUM_SIZE_16X16_ICON => 16;
+
+# This is a list of all tags that should be in every menu item.
+my @req_tags = qw(needs section title command);
+
+# This is a list of all known tags.
+my @known_tags = qw(
+ needs
+ section
+ title
+ sort
+ command
+ longtitle
+ icon
+ icon16x16
+ icon32x32
+ description
+ hotkey
+ hints
+);
+
+# These 'needs' tags are always valid, no matter the context, and no other
+# values are valid outside the Window Managers context (don't include wm here,
+# in other words). It's case insensitive, use lower case here.
+my @needs_tag_vals = qw(x11 text vc);
+
+has MENU_SECTIONS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %menu_sections;
+
+ my $data = $self->data->load('menu-format/menu-sections');
+
+ for my $key ($data->all) {
+
+ my ($root, $under) = split(m{/}, $key, 2);
+
+ $under //= $EMPTY;
+
+ # $under is empty if this is just a root section
+ $menu_sections{$root}{$under} = 1;
+ }
+
+ return \%menu_sections;
+ }
+);
+
+# Authoritative source of desktop keys:
+# https://specifications.freedesktop.org/desktop-entry-spec/latest/
+#
+# This is a list of all keys that should be in every desktop entry.
+my @req_desktop_keys = qw(Type Name);
+
+# This is a list of all known keys.
+has KNOWN_DESKTOP_KEYS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('menu-format/known-desktop-keys');
+ }
+);
+
+has DEPRECATED_DESKTOP_KEYS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('menu-format/deprecated-desktop-keys');
+ }
+);
+
+# KDE uses some additional keys that should start with X-KDE but don't for
+# historical reasons.
+has KDE_DESKTOP_KEYS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('menu-format/kde-desktop-keys');
+ }
+);
+
+# Known types of desktop entries.
+# https://specifications.freedesktop.org/desktop-entry-spec/latest/ar01s06.html
+my %known_desktop_types = map { $_ => 1 } qw(
+ Application
+ Link
+ Directory
+);
+
+# Authoritative source of desktop categories:
+# https://specifications.freedesktop.org/menu-spec/latest/apa.html
+
+# This is a list of all Main Categories for .desktop files. Application is
+# added as an exception; it's not listed in the standard, but it's widely used
+# and used as an example in the GNOME documentation. GNUstep is added as an
+# exception since it's used by GNUstep packages.
+my %main_categories = map { $_ => 1 } qw(
+ AudioVideo
+ Audio
+ Video
+ Development
+ Education
+ Game
+ Graphics
+ Network
+ Office
+ Science
+ Settings
+ System
+ Utility
+ Application
+ GNUstep
+);
+
+# This is a list of all Additional Categories for .desktop files. Ideally we
+# should be checking to be sure the associated Main Categories are present,
+# but we don't have support for that yet.
+has ADD_CATEGORIES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->data->load('menu-format/add-categories');
+ }
+);
+
+# This is a list of Reserved Categories for .desktop files. To use one of
+# these, the desktop entry must also have an OnlyShowIn key limiting the
+# environment to one that supports this category.
+my %reserved_categories = map { $_ => 1 } qw(
+ Screensaver
+ TrayIcon
+ Applet
+ Shell
+);
+
+# Path in which to search for binaries referenced in menu entries. These must
+# not have leading slashes.
+my @path = qw(usr/local/bin/ usr/bin/ bin/ usr/games/);
+
+my %known_tags_hash = map { $_ => 1 } @known_tags;
+my %needs_tag_vals_hash = map { $_ => 1 } @needs_tag_vals;
+
+# -----------------------------------
+
+sub installable {
+ my ($self) = @_;
+
+ my $index = $self->processable->installed;
+
+ my (@menufiles, %desktop_cmds);
+ for my $dirname (qw(usr/share/menu/ usr/lib/menu/)) {
+ if (my $dir = $index->resolve_path($dirname)) {
+ push(@menufiles, $dir->children);
+ }
+ }
+
+ # Find the desktop files in the package for verification.
+ my @desktop_files;
+ for my $subdir (qw(applications xsessions)) {
+ if (my $dir = $index->lookup("usr/share/$subdir/")) {
+ for my $item ($dir->children) {
+ next
+ unless $item->is_file;
+
+ next
+ if $item->is_dir;
+
+ next
+ unless $item->basename =~ /\.desktop$/;
+
+ $self->pointed_hint('executable-desktop-file', $item->pointer,
+ $item->octal_permissions)
+ if $item->is_executable;
+
+ push(@desktop_files, $item)
+ unless $item->name =~ / template /msx;
+ }
+ }
+ }
+
+ # Verify all the desktop files.
+ for my $desktop_file (@desktop_files) {
+ $self->verify_desktop_file($desktop_file, \%desktop_cmds);
+ }
+
+ # Now all the menu files.
+ for my $menufile (@menufiles) {
+ # Do not try to parse executables
+ next if $menufile->is_executable or not $menufile->is_open_ok;
+
+ # README is a special case
+ next if $menufile->basename eq 'README' && !$menufile->is_dir;
+ my $menufile_line =$EMPTY;
+
+ open(my $fd, '<', $menufile->unpacked_path)
+ or die encode_utf8('Cannot open ' . $menufile->unpacked_path);
+
+ # line below is commented out in favour of the while loop
+ # do { $_=<IN>; } while defined && (m/^\s* \#/ || m/^\s*$/);
+ while (my $line = <$fd>) {
+ if ($line =~ /^\s*\#/ || $line =~ /^\s*$/) {
+ next;
+
+ } else {
+ $menufile_line = $line;
+ last;
+ }
+ }
+
+ # Check first line of file to see if it matches the new menu
+ # file format.
+ if ($menufile_line =~ m/^!C\s*menu-2/) {
+ # we can't parse that yet
+ close($fd);
+ next;
+ }
+
+ # Parse entire file as a new format menu file.
+ my $line=$EMPTY;
+ my $lc=0;
+ do {
+ $lc++;
+
+ # Ignore lines that are comments.
+ if ($menufile_line =~ m/^\s*\#/) {
+ next;
+ }
+ $line .= $menufile_line;
+ # Note that I allow whitespace after the continuation character.
+ # This is caught by verify_line().
+ if (!($menufile_line =~ m/\\\s*?$/)) {
+ $self->verify_line($menufile, $line,$lc,\%desktop_cmds);
+ $line=$EMPTY;
+ }
+ } while ($menufile_line = <$fd>);
+ $self->verify_line($menufile, $line,$lc,\%desktop_cmds);
+
+ close($fd);
+ }
+
+ return;
+}
+
+# -----------------------------------
+
+# Pass this a line of a menu file, it sanitizes it and
+# verifies that it is correct.
+sub verify_line {
+ my ($self, $menufile, $line, $position,$desktop_cmds) = @_;
+
+ my $pointer = $menufile->pointer($position);
+ my %vals;
+
+ chomp $line;
+
+ # Replace all line continuation characters with whitespace.
+ # (do not remove them completely, because update-menus doesn't)
+ $line =~ s/\\\n/ /mg;
+
+ # This is in here to fix a common mistake: whitespace after a '\'
+ # character.
+ if ($line =~ s/\\\s+\n/ /mg) {
+ $self->pointed_hint('whitespace-after-continuation-character',
+ $pointer);
+ }
+
+ # Ignore lines that are all whitespace or empty.
+ return if $line =~ m/^\s*$/;
+
+ # Ignore lines that are comments.
+ return if $line =~ m/^\s*\#/;
+
+ # Start by testing the package check.
+ if (not $line =~ m/^\?package\((.*?)\):/) {
+ $self->pointed_hint('bad-test-in-menu-item', $pointer);
+ return;
+ }
+ my $pkg_test = $1;
+ my %tested_packages = map { $_ => 1 } split(/\s*,\s*/, $pkg_test);
+ my $tested_packages = scalar keys %tested_packages;
+ unless (exists $tested_packages{$self->processable->name}) {
+ $self->pointed_hint('pkg-not-in-package-test', $pointer, $pkg_test);
+ }
+ $line =~ s/^\?package\(.*?\)://;
+
+ # Now collect all the tag=value pairs. I've heavily commented
+ # the killer regexp that's responsible.
+ #
+ # The basic idea here is we start at the beginning of the line.
+ # Each loop pulls off one tag=value pair and advances to the next
+ # when we have no more matches, there should be no text left on
+ # the line - if there is, it's a parse error.
+ while (
+ $line =~ m{
+ \s*? # allow whitespace between pairs
+ ( # capture what follows in $1, it's our tag
+ [^\"\s=] # a non-quote, non-whitespace, character
+ * # match as many as we can
+ )
+ =
+ ( # capture what follows in $2, it's our value
+ (?:
+ \" # this is a quoted string
+ (?:
+ \\. # any quoted character
+ | # or
+ [^\"] # a non-quote character
+ )
+ * # repeat as many times as possible
+ \" # end of the quoted value string
+ )
+ | # the other possibility is a non-quoted string
+ (?:
+ [^\"\s] # a non-quote, non-whitespace character
+ * # match as many times as we can
+ )
+ )
+ }gcx
+ ) {
+ my $tag = $1;
+ my $value = $2;
+
+ if (exists $vals{$tag}) {
+ $self->pointed_hint('duplicate-tag-in-menu', $pointer, $1);
+ }
+
+ # If the value was quoted, remove those quotes.
+ if ($value =~ m/^\"(.*)\"$/) {
+ $value = $1;
+ } else {
+ $self->pointed_hint('unquoted-string-in-menu-item',$pointer, $1);
+ }
+
+ # If the value has escaped characters, remove the
+ # escapes.
+ $value =~ s/\\(.)/$1/g;
+
+ $vals{$tag} = $value;
+ }
+
+ # This is not really a no-op. Note the use of the /c
+ # switch - this makes perl keep track of the current
+ # search position. Notice, we did it above in the loop,
+ # too. (I have a /g here just so the /c takes affect.)
+ # We use this below when we look at how far along in the
+ # string we matched. So the point of this line is to allow
+ # trailing whitespace on the end of a line.
+ $line =~ m/\s*/gc;
+
+ # If that loop didn't match up to end of line, we have a
+ # problem..
+ if (pos($line) < length($line)) {
+ $self->pointed_hint('unparsable-menu-item', $pointer);
+ # Give up now, before things just blow up in our face.
+ return;
+ }
+
+ # Now validate the data in the menu file.
+
+ # Test for important tags.
+ for my $tag (@req_tags) {
+ unless (exists($vals{$tag}) && defined($vals{$tag})) {
+ $self->pointed_hint('menu-item-missing-required-tag',
+ $pointer, $tag);
+ # Just give up right away, if such an essential tag is missing,
+ # chance is high the rest doesn't make sense either. And now all
+ # following checks can assume those tags to be there
+ return;
+ }
+ }
+
+ # Make sure all tags are known.
+ for my $tag (keys %vals) {
+ if (!$known_tags_hash{$tag}) {
+ $self->pointed_hint('menu-item-contains-unknown-tag',
+ $pointer, $tag);
+ }
+ }
+
+ # Sanitize the section tag
+ my $section = $vals{'section'};
+ $section =~ tr:/:/:s; # eliminate duplicate slashes. # Hallo emacs ;;
+ $section =~ s{/$}{} # remove trailing slash
+ unless $section eq $SLASH; # - except if $section is '/'
+
+ # Be sure the command is provided by the package.
+ my ($okay, $command)
+ = $self->verify_cmd($pointer, $vals{'command'});
+
+ $self->pointed_hint('menu-command-not-in-package', $pointer, $command)
+ if !$okay
+ && length $command
+ && $tested_packages < 2
+ && $section !~ m{^(?:WindowManagers/Modules|FVWM Modules|Window Maker)};
+
+ if (length $command) {
+ $command =~ s{^(?:usr/)?s?bin/}{};
+ $command =~ s{^usr/games/}{};
+
+ $self->pointed_hint('command-in-menu-file-and-desktop-file',
+ $pointer, $command)
+ if $desktop_cmds->{$command};
+ }
+
+ $self->verify_icon('icon', $vals{'icon'},$MAXIMUM_SIZE_STANDARD_ICON,
+ $pointer);
+ $self->verify_icon('icon32x32', $vals{'icon32x32'},
+ $MAXIMUM_SIZE_32X32_ICON, $pointer);
+ $self->verify_icon('icon16x16', $vals{'icon16x16'},
+ $MAXIMUM_SIZE_16X16_ICON, $pointer);
+
+ # needs is case insensitive
+ my $needs = lc($vals{'needs'});
+
+ if ($section =~ m{^(WindowManagers/Modules|FVWM Modules|Window Maker)}) {
+ # WM/Modules: needs must not be the regular ones nor wm
+ $self->pointed_hint('non-wm-module-in-wm-modules-menu-section',
+ $pointer, $needs)
+ if $needs_tag_vals_hash{$needs} || $needs eq 'wm';
+
+ } elsif ($section =~ m{^Window ?Managers}) {
+ # Other WM sections: needs must be wm
+ $self->pointed_hint('non-wm-in-windowmanager-menu-section',
+ $pointer, $needs)
+ unless $needs eq 'wm';
+
+ } else {
+ # Any other section: just only the general ones
+ if ($needs eq 'dwww') {
+ $self->pointed_hint('menu-item-needs-dwww', $pointer);
+
+ } elsif (!$needs_tag_vals_hash{$needs}) {
+ $self->pointed_hint('menu-item-needs-tag-has-unknown-value',
+ $pointer, $needs);
+ }
+ }
+
+ # Check the section tag
+ # Check for historical changes in the section tree.
+ if ($section =~ m{^Apps/Games}) {
+ $self->pointed_hint('menu-item-uses-apps-games-section', $pointer);
+ $section =~ s{^Apps/}{};
+ }
+
+ if ($section =~ m{^Apps/}) {
+ $self->pointed_hint('menu-item-uses-apps-section', $pointer);
+ $section =~ s{^Apps/}{Applications/};
+ }
+
+ if ($section =~ m{^WindowManagers}) {
+ $self->pointed_hint('menu-item-uses-windowmanagers-section', $pointer);
+ $section =~ s{^WindowManagers}{Window Managers};
+ }
+
+ # Check for Evil new root sections.
+ my ($rootsec, $sect) = split(m{/}, $section, 2);
+
+ my $root_data = $self->MENU_SECTIONS->{$rootsec};
+
+ if (!defined $root_data) {
+
+ my $pkg = $self->processable->name;
+ $self->pointed_hint('menu-item-creates-new-root-section',
+ $pointer, $rootsec)
+ unless $rootsec =~ /$pkg/i;
+
+ } else {
+
+ $self->pointed_hint('menu-item-creates-new-section',
+ $pointer, $vals{section})
+ if (length $sect && !exists $root_data->{$sect})
+ || (!length $sect && !exists $root_data->{$EMPTY});
+ }
+
+ return;
+}
+
+sub verify_icon {
+ my ($self, $tag, $name, $size, $pointer)= @_;
+
+ return
+ unless length $name;
+
+ if ($name eq 'none') {
+
+ $self->pointed_hint('menu-item-uses-icon-none', $pointer, $tag);
+ return;
+ }
+
+ $self->pointed_hint('menu-icon-uses-relative-path', $pointer, $tag, $name)
+ unless $name =~ s{^/+}{};
+
+ if ($name !~ /\.xpm$/i) {
+
+ $self->pointed_hint('menu-icon-not-in-xpm-format',
+ $pointer, $tag, $name);
+ return;
+ }
+
+ my @packages = (
+ $self->processable,
+ @{ $self->group->direct_dependencies($self->processable) }
+ );
+
+ my @candidates;
+ for my $processable (@packages) {
+
+ push(@candidates, $processable->installed->resolve_path($name));
+ push(@candidates,
+ $processable->installed->resolve_path("usr/share/pixmaps/$name"));
+ }
+
+ my $iconfile = first_value { defined } @candidates;
+
+ if (!defined $iconfile || !$iconfile->is_open_ok) {
+
+ $self->pointed_hint('menu-icon-missing', $pointer, $tag, $name);
+ return;
+ }
+
+ open(my $fd, '<', $iconfile->unpacked_path)
+ or die encode_utf8('Cannot open ' . $iconfile->unpacked_path);
+
+ my $parse = 'XPM header';
+
+ my $line;
+ do { defined($line = <$fd>) or goto PARSE_ERROR; }
+ until ($line =~ /\/\*\s*XPM\s*\*\//);
+
+ $parse = 'size line';
+
+ do { defined($line = <$fd>) or goto PARSE_ERROR; }
+ until ($line =~ /"\s*([0-9]+)\s*([0-9]+)\s*(?:[0-9]+)\s*(?:[0-9]+)\s*"/);
+ my $width = $1 + 0;
+ my $height = $2 + 0;
+
+ if ($width > $size || $height > $size) {
+ $self->pointed_hint('menu-icon-too-big', $pointer, $tag,
+ "$name: ${width}x${height} > ${size}x${size}");
+ }
+
+ close($fd);
+
+ return;
+
+ PARSE_ERROR:
+ close($fd);
+ $self->pointed_hint('menu-icon-cannot-be-parsed', $pointer, $tag,
+ "$name: looking for $parse");
+
+ return;
+}
+
+# Syntax-checks a .desktop file.
+sub verify_desktop_file {
+ my ($self, $item, $desktop_cmds) = @_;
+
+ my ($saw_first, $warned_cr, %vals, @pending);
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my $pointer = $item->pointer($position);
+
+ next
+ if $line =~ /^\s*\#/ || $line =~ /^\s*$/;
+
+ if ($line =~ s/\r//) {
+ $self->pointed_hint('desktop-entry-file-has-crs', $pointer)
+ unless $warned_cr;
+ $warned_cr = 1;
+ }
+
+ # Err on the side of caution for now. If the first non-comment line
+ # is not the required [Desktop Entry] group, ignore this file. Also
+ # ignore any keys in other groups.
+ last
+ if $saw_first && $line =~ /^\[(.*)\]\s*$/;
+
+ unless ($saw_first) {
+ return
+ unless $line =~ /^\[(KDE )?Desktop Entry\]\s*$/;
+ $saw_first = 1;
+ $self->pointed_hint('desktop-contains-deprecated-key', $pointer)
+ if $line =~ /^\[KDE Desktop Entry\]\s*$/;
+ }
+
+ # Tag = Value. For most errors, just add the error to pending rather
+ # than warning on it immediately since we want to not warn on tag
+ # errors if we didn't know the file type.
+ #
+ # TODO: We do not check for properly formatted localised values for
+ # keys but might be worth checking if they are properly formatted (not
+ # their value)
+ if ($line =~ /^(.*?)\s*=\s*(.*)$/) {
+ my ($tag, $value) = ($1, $2);
+ my $basetag = $tag;
+ $basetag =~ s/\[([^\]]+)\]$//;
+ if (exists $vals{$tag}) {
+ $self->pointed_hint('duplicate-key-in-desktop', $pointer,$tag);
+ } elsif ($self->DEPRECATED_DESKTOP_KEYS->recognizes($basetag)) {
+ if ($basetag eq 'Encoding') {
+ push(@pending,
+ ['desktop-entry-contains-encoding-key',$pointer, $tag]
+ );
+ } else {
+ push(
+ @pending,
+ [
+ 'desktop-entry-contains-deprecated-key',
+ $pointer, $tag
+ ]
+ );
+ }
+ } elsif (not $self->KNOWN_DESKTOP_KEYS->recognizes($basetag)
+ and not $self->KDE_DESKTOP_KEYS->recognizes($basetag)
+ and not $basetag =~ /^X-/) {
+ push(@pending,
+ ['desktop-entry-contains-unknown-key', $pointer, $tag]);
+ }
+ $vals{$tag} = $value;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close($fd);
+
+ # Now validate the data in the desktop file, but only if it's a known type.
+ # Warn if it's not.
+ my $type = $vals{'Type'};
+ return
+ unless defined $type;
+
+ unless ($known_desktop_types{$type}) {
+ $self->pointed_hint('desktop-entry-unknown-type', $item->pointer,
+ $type);
+ return;
+ }
+
+ $self->pointed_hint(@{$_}) for @pending;
+
+ # Test for important keys.
+ for my $tag (@req_desktop_keys) {
+ unless (defined $vals{$tag}) {
+ $self->pointed_hint('desktop-entry-missing-required-key',
+ $item->pointer, $tag);
+ }
+ }
+
+ # test if missing Keywords (only if NoDisplay is not set)
+ if (!defined $vals{NoDisplay}) {
+
+ $self->pointed_hint('desktop-entry-lacks-icon-entry', $item->pointer)
+ unless defined $vals{Icon};
+
+ $self->pointed_hint('desktop-entry-lacks-keywords-entry',
+ $item->pointer)
+ if !defined $vals{Keywords} && $vals{'Type'} eq 'Application';
+ }
+
+ # Only test whether the binary is in the package if the desktop file is
+ # directly under /usr/share/applications. Too many applications use
+ # desktop files for other purposes with custom paths.
+ #
+ # TODO: Should check quoting and the check special field
+ # codes in Exec for desktop files.
+ if ( $item->name =~ m{^usr/share/applications/}
+ && $vals{'Exec'}
+ && $vals{'Exec'} =~ /\S/) {
+
+ my ($okay, $command)
+ = $self->verify_cmd($item->pointer, $vals{'Exec'});
+
+ $self->pointed_hint('desktop-command-not-in-package',
+ $item->pointer, $command)
+ unless $okay
+ || $command eq 'kcmshell';
+
+ $command =~ s{^(?:usr/)?s?bin/}{};
+ $desktop_cmds->{$command} = 1
+ unless $command =~ m/^(?:su-to-root|sux?|(?:gk|kde)su)$/;
+ }
+
+ # Check the Category tag.
+ my $in_reserved;
+ if (defined $vals{'Categories'}) {
+
+ my $saw_main;
+
+ my @categories = split(/;/, $vals{'Categories'});
+ for my $category (@categories) {
+
+ next
+ if $category =~ /^X-/;
+
+ if ($reserved_categories{$category}) {
+ $self->pointed_hint('desktop-entry-uses-reserved-category',
+ $item->pointer,$category)
+ unless $vals{'OnlyShowIn'};
+
+ $saw_main = 1;
+ $in_reserved = 1;
+
+ } elsif (!$self->ADD_CATEGORIES->recognizes($category)
+ && !$main_categories{$category}) {
+ $self->pointed_hint('desktop-entry-invalid-category',
+ $item->pointer, $category);
+
+ } elsif ($main_categories{$category}) {
+ $saw_main = 1;
+ }
+ }
+
+ $self->pointed_hint('desktop-entry-lacks-main-category',$item->pointer)
+ unless $saw_main;
+ }
+
+ # Check the OnlyShowIn tag. If this is not an application in a reserved
+ # category, warn about any desktop entry that specifies OnlyShowIn for
+ # more than one environment. In that case, the application probably
+ # should be using NotShowIn instead.
+ if (defined $vals{OnlyShowIn} and not $in_reserved) {
+ my @envs = split(/;/, $vals{OnlyShowIn});
+ if (@envs > 1) {
+ $self->pointed_hint('desktop-entry-limited-to-environments',
+ $item->pointer);
+ }
+ }
+
+ # Check that the Exec tag specifies how to pass a filename if MimeType
+ # tags are present.
+ if ($item->name =~ m{^usr/share/applications/}
+ && defined $vals{'MimeType'}) {
+
+ $self->pointed_hint('desktop-mime-but-no-exec-code', $item->pointer)
+ unless defined $vals{'Exec'}
+ && $vals{'Exec'} =~ /(?:^|[^%])%[fFuU]/;
+ }
+
+ return;
+}
+
+# Verify whether a command is shipped as part of the package. Takes the full
+# path to the file being checked (for error reporting) and the binary.
+# Returns a list whose first member is true if the command is present and
+# false otherwise, and whose second member is the command (minus any leading
+# su-to-root wrapper). Shared between the desktop and menu code.
+sub verify_cmd {
+ my ($self, $pointer, $exec) = @_;
+
+ my $index = $self->processable->installed;
+
+ # This routine handles su wrappers. The option parsing here is ugly and
+ # dead-simple, but it's hopefully good enough for what will show up in
+ # desktop files. su-to-root and sux require -c options, kdesu optionally
+ # allows one, and gksu has the command at the end of its arguments.
+ my @components = split($SPACE, $exec);
+ my $cmd;
+
+ $self->pointed_hint('su-to-root-with-usr-sbin', $pointer)
+ if $components[0] && $components[0] eq '/usr/sbin/su-to-root';
+
+ if ( $components[0]
+ && $components[0] =~ m{^(?:/usr/s?bin/)?(su-to-root|gksu|kdesu|sux)$}){
+
+ my $wrapper = $1;
+ shift @components;
+
+ while (@components) {
+ unless ($components[0]) {
+ shift @components;
+ next;
+ }
+
+ if ($components[0] eq '-c') {
+ $cmd = $components[1];
+ last;
+
+ } elsif (
+ $components[0] =~ /^-[Dfmupi]|^--(user|description|message)/) {
+ shift @components;
+ shift @components;
+
+ } elsif ($components[0] =~ /^-/) {
+ shift @components;
+
+ } else {
+ last;
+ }
+ }
+
+ if (!$cmd && $wrapper =~ /^(gk|kde)su$/) {
+ if (@components) {
+ $cmd = $components[0];
+ } else {
+ $cmd = $wrapper;
+ undef $wrapper;
+ }
+ }
+
+ $self->pointed_hint('su-wrapper-without--c', $pointer, $wrapper)
+ unless $cmd;
+
+ $self->pointed_hint('su-wrapper-not-su-to-root', $pointer, $wrapper)
+ if $wrapper
+ && $wrapper !~ /su-to-root/
+ && $wrapper ne $self->processable->name;
+
+ } else {
+ $cmd = $components[0];
+ }
+
+ my $cmd_file = $cmd;
+ if ($cmd_file) {
+ $cmd_file =~ s{^/}{};
+ }
+
+ my $okay = $cmd
+ && ( $cmd =~ /^[\'\"]/
+ || $index->lookup($cmd_file)
+ || $cmd =~ m{^(/bin/)?sh}
+ || $cmd =~ m{^(/usr/bin/)?sensible-(pager|editor|browser)}
+ || any { $index->lookup($_ . $cmd) } @path);
+
+ return ($okay, $cmd_file);
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Menus.pm b/lib/Lintian/Check/Menus.pm
new file mode 100644
index 0000000..2e8f3d1
--- /dev/null
+++ b/lib/Lintian/Check/Menus.pm
@@ -0,0 +1,818 @@
+# menus -- lintian check script -*- perl -*-
+
+# somewhat of a misnomer -- it doesn't only check menus
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Menus;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Spelling qw(check_spelling check_spelling_picky);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $DOT => q{.};
+const my $QUESTION_MARK => q{?};
+
+# Supported documentation formats for doc-base files.
+my %known_doc_base_formats
+ = map { $_ => 1 }qw(html text pdf postscript info dvi debiandoc-sgml);
+
+# Known fields for doc-base files. The value is 1 for required fields and 0
+# for optional fields.
+my %KNOWN_DOCBASE_MAIN_FIELDS = (
+ 'Document' => 1,
+ 'Title' => 1,
+ 'Section' => 1,
+ 'Abstract' => 0,
+ 'Author' => 0
+);
+
+my %KNOWN_DOCBASE_FORMAT_FIELDS = (
+ 'Format' => 1,
+ 'Files' => 1,
+ 'Index' => 0
+);
+
+has menu_item => (is => 'rw');
+has menumethod_item => (is => 'rw');
+has documentation => (is => 'rw', default => 0);
+
+sub spelling_tag_emitter {
+ my ($self, @orig_args) = @_;
+
+ return sub {
+ return $self->pointed_hint(@orig_args, @_);
+ };
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->is_file) { # file checks
+ # menu file?
+ if ($item->name =~ m{^usr/(lib|share)/menu/\S}){ # correct permissions?
+
+ $self->pointed_hint('executable-menu-file', $item->pointer,
+ $item->octal_permissions)
+ if $item->is_executable;
+
+ return
+ if $item->name =~ m{^usr/(?:lib|share)/menu/README$};
+
+ if ($item->name =~ m{^usr/lib/}) {
+ $self->pointed_hint('menu-file-in-usr-lib', $item->pointer);
+ }
+
+ $self->menu_item($item);
+
+ $self->pointed_hint('bad-menu-file-name', $item->pointer)
+ if $item->name =~ m{^usr/(?:lib|share)/menu/menu$}
+ && $self->processable->name ne 'menu';
+ }
+ #menu-methods file?
+ elsif ($item->name =~ m{^etc/menu-methods/\S}) {
+ #TODO: we should test if the menu-methods file
+ # is made executable in the postinst as recommended by
+ # the menu manual
+
+ my $menumethod_includes_menu_h = 0;
+ $self->menumethod_item($item);
+
+ if ($item->is_open_ok) {
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ while (my $line = <$fd>) {
+ chomp $line;
+ if ($line =~ /^!include menu.h/) {
+ $menumethod_includes_menu_h = 1;
+ last;
+ }
+ }
+ close($fd);
+ }
+
+ $self->pointed_hint('menu-method-lacks-include', $item->pointer)
+ unless $menumethod_includes_menu_h
+ or $self->processable->name eq 'menu';
+ }
+ # package doc dir?
+ elsif (
+ $item->name =~ m{ \A usr/share/doc/(?:[^/]+/)?
+ (.+\.(?:html|pdf))(?:\.gz)?
+ \Z}xsm
+ ) {
+ my $name = $1;
+ unless ($name =~ m/^changelog\.html$/
+ or $name =~ m/^README[.-]/
+ or $name =~ m/examples/) {
+ $self->documentation(1);
+ }
+ }
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $pkg = $self->processable->name;
+ my $processable = $self->processable;
+ my $group = $self->group;
+
+ my (%all_files, %all_links);
+
+ my %preinst;
+ my %postinst;
+ my %prerm;
+ my %postrm;
+
+ $self->check_script($processable->control->lookup('preinst'),\%preinst);
+ $self->check_script($processable->control->lookup('postinst'),\%postinst);
+ $self->check_script($processable->control->lookup('prerm'),\%prerm);
+ $self->check_script($processable->control->lookup('postrm'),\%postrm);
+
+ # Populate all_{files,links} from current package and its dependencies
+ for my $installable ($group->get_installables) {
+ next
+ unless $processable->name eq $installable->name
+ || $processable->relation('strong')->satisfies($installable->name);
+
+ for my $item (@{$installable->installed->sorted_list}) {
+ add_file_link_info($installable, $item->name, \%all_files,
+ \%all_links);
+ }
+ }
+
+ # prerm scripts should not call update-menus
+ $self->pointed_hint('prerm-calls-updatemenus',$prerm{'calls-updatemenus'})
+ if defined $prerm{'calls-updatemenus'};
+
+ # postrm scripts should not call install-docs
+ $self->pointed_hint('postrm-calls-installdocs',
+ $postrm{'calls-installdocs'})
+ if defined $postrm{'calls-installdocs'};
+ $self->pointed_hint('postrm-calls-installdocs',
+ $postrm{'calls-installdocs-r'})
+ if defined $postrm{'calls-installdocs-r'};
+
+ # preinst scripts should not call either update-menus nor installdocs
+ $self->pointed_hint('preinst-calls-updatemenus',
+ $preinst{'calls-updatemenus'})
+ if defined $preinst{'calls-updatemenus'};
+
+ $self->pointed_hint('preinst-calls-installdocs',
+ $preinst{'calls-installdocs'})
+ if defined $preinst{'calls-installdocs'};
+
+ my $anymenu_item = $self->menu_item || $self->menumethod_item;
+
+ # No one needs to call install-docs any more; triggers now handles that.
+ $self->pointed_hint('postinst-has-useless-call-to-install-docs',
+ $postinst{'calls-installdocs'})
+ if defined $postinst{'calls-installdocs'};
+ $self->pointed_hint('postinst-has-useless-call-to-install-docs',
+ $postinst{'calls-installdocs-r'})
+ if defined $postinst{'calls-installdocs-r'};
+
+ $self->pointed_hint('prerm-has-useless-call-to-install-docs',
+ $prerm{'calls-installdocs'})
+ if defined $prerm{'calls-installdocs'};
+ $self->pointed_hint('prerm-has-useless-call-to-install-docs',
+ $prerm{'calls-installdocs-r'})
+ if defined $prerm{'calls-installdocs-r'};
+
+ # check consistency
+ # docbase file?
+ if (my $db_dir
+ = $processable->installed->resolve_path('usr/share/doc-base/')){
+ for my $item ($db_dir->children) {
+ next
+ if !$item->is_open_ok;
+
+ if ($item->resolve_path->is_executable) {
+
+ $self->pointed_hint('executable-in-usr-share-docbase',
+ $item->pointer, $item->octal_permissions);
+ next;
+ }
+
+ $self->check_doc_base_file($item, \%all_files,\%all_links);
+ }
+ } elsif ($self->documentation) {
+ if ($pkg =~ /^libghc6?-.*-doc$/) {
+ # This is the library documentation for a haskell library. Haskell
+ # libraries register their documentation via the ghc compiler's
+ # documentation registration mechanism. See bug #586877.
+ } else {
+ $self->hint('possible-documentation-but-no-doc-base-registration');
+ }
+ }
+
+ if ($anymenu_item) {
+ # postinst and postrm should not need to call update-menus
+ # unless there is a menu-method file. However, update-menus
+ # currently won't enable packages that have outstanding
+ # triggers, leading to an update-menus call being required for
+ # at least some packages right now. Until this bug is fixed,
+ # we still require it. See #518919 for more information.
+ #
+ # That bug does not require calling update-menus from postrm,
+ # but debhelper apparently currently still adds that to the
+ # maintainer script, so don't warn if it's done.
+ $self->pointed_hint('postinst-does-not-call-updatemenus',
+ $anymenu_item->pointer)
+ if !defined $postinst{'calls-updatemenus'};
+
+ $self->pointed_hint(
+ 'postrm-does-not-call-updatemenus',
+ $self->menumethod_item->pointer
+ )
+ if defined $self->menumethod_item
+ && !defined $postrm{'calls-updatemenus'}
+ && $pkg ne 'menu';
+
+ } else {
+ $self->pointed_hint('postinst-has-useless-call-to-update-menus',
+ $postinst{'calls-updatemenus'})
+ if defined $postinst{'calls-updatemenus'};
+
+ $self->pointed_hint('postrm-has-useless-call-to-update-menus',
+ $postrm{'calls-updatemenus'})
+ if defined $postrm{'calls-updatemenus'};
+ }
+
+ return;
+}
+
+# -----------------------------------
+
+sub check_doc_base_file {
+ my ($self, $item, $all_files, $all_links) = @_;
+
+ my $pkg = $self->processable->name;
+ my $group = $self->group;
+
+ # another check complains about invalid encoding
+ return
+ unless ($item->is_valid_utf8);
+
+ my $contents = $item->decoded_utf8;
+ my @lines = split(/\n/, $contents);
+
+ my $knownfields = \%KNOWN_DOCBASE_MAIN_FIELDS;
+ my ($field, @vals);
+ my %sawfields; # local for each section of control file
+ my %sawformats; # global for control file
+ my $line = 0; # global
+
+ my $position = 1;
+ while (defined(my $string = shift @lines)) {
+ chomp $string;
+
+ # New field. check previous field, if we have any.
+ if ($string =~ /^(\S+)\s*:\s*(.*)$/) {
+ my (@new) = ($1, $2);
+ if ($field) {
+ $self->check_doc_base_field(
+ $item, $line, $field,
+ \@vals,\%sawfields, \%sawformats,
+ $knownfields,$all_files, $all_links
+ );
+ }
+
+ $field = $new[0];
+
+ @vals = ($new[1]);
+ $line = $position;
+
+ # Continuation of previously defined field.
+ } elsif ($field && $string =~ /^\s+\S/) {
+ push(@vals, $string);
+
+ # All tags will be reported on the last continuation line of the
+ # doc-base field.
+ $line = $position;
+
+ # Sections' separator.
+ } elsif ($string =~ /^(\s*)$/) {
+ $self->pointed_hint('doc-base-file-separator-extra-whitespace',
+ $item->pointer($position))
+ if $1;
+ next unless $field; # skip successive empty lines
+
+ # Check previously defined field and section.
+ $self->check_doc_base_field(
+ $item, $line, $field,
+ \@vals,\%sawfields, \%sawformats,
+ $knownfields,$all_files, $all_links
+ );
+ $self->check_doc_base_file_section($item, $line + 1,\%sawfields,
+ \%sawformats, $knownfields);
+
+ # Initialize variables for new section.
+ undef $field;
+ undef $line;
+ @vals = ();
+ %sawfields = ();
+
+ # Each section except the first one is format section.
+ $knownfields = \%KNOWN_DOCBASE_FORMAT_FIELDS;
+
+ # Everything else is a syntax error.
+ } else {
+ $self->pointed_hint('doc-base-file-syntax-error',
+ $item->pointer($position));
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ # Check the last field/section of the control file.
+ if ($field) {
+ $self->check_doc_base_field(
+ $item, $line, $field,
+ \@vals, \%sawfields,\%sawformats,
+ $knownfields,$all_files,$all_links
+ );
+ $self->check_doc_base_file_section($item, $line, \%sawfields,
+ \%sawformats,$knownfields);
+ }
+
+ # Make sure we saw at least one format.
+ $self->pointed_hint('doc-base-file-no-format-section', $item->pointer)
+ unless %sawformats;
+
+ return;
+}
+
+# Checks one field of a doc-base control file. $vals is array ref containing
+# all lines of the field. Modifies $sawfields and $sawformats.
+sub check_doc_base_field {
+ my (
+ $self, $item, $position, $field,$vals,
+ $sawfields, $sawformats,$knownfields,$all_files, $all_links
+ ) = @_;
+
+ my $pkg = $self->processable->name;
+ my $group = $self->group;
+
+ my $SECTIONS = $self->data->load('doc-base/sections');
+
+ $self->pointed_hint('doc-base-file-unknown-field',
+ $item->pointer($position), $field)
+ unless defined $knownfields->{$field};
+ $self->pointed_hint('duplicate-field-in-doc-base',
+ $item->pointer($position), $field)
+ if $sawfields->{$field};
+ $sawfields->{$field} = 1;
+
+ # Index/Files field.
+ #
+ # Check if files referenced by doc-base are included in the package. The
+ # Index field should refer to only one file without wildcards. The Files
+ # field is a whitespace-separated list of files and may contain wildcards.
+ # We skip without validating wildcard patterns containing character
+ # classes since otherwise we'd need to deal with wildcards inside
+ # character classes and aren't there yet.
+ if ($field eq 'Index' or $field eq 'Files') {
+ my @files = map { split($SPACE) } @{$vals};
+
+ if ($field eq 'Index' && @files > 1) {
+ $self->pointed_hint('doc-base-index-references-multiple-files',
+ $item->pointer($position));
+ }
+ for my $file (@files) {
+ next if $file =~ m{^/usr/share/doc/};
+ next if $file =~ m{^/usr/share/info/};
+
+ $self->pointed_hint('doc-base-file-references-wrong-path',
+ $item->pointer($position), $file);
+ }
+ for my $file (@files) {
+ my $realfile = delink($file, $all_links);
+ # openoffice.org-dev-doc has thousands of files listed so try to
+ # use the hash if possible.
+ my $found;
+ if ($realfile =~ /[*?]/) {
+ my $regex = quotemeta($realfile);
+ unless ($field eq 'Index') {
+ next if $regex =~ /\[/;
+ $regex =~ s{\\\*}{[^/]*}g;
+ $regex =~ s{\\\?}{[^/]}g;
+ $regex .= $SLASH . $QUESTION_MARK;
+ }
+ $found = grep { /^$regex\z/ } keys %{$all_files};
+ } else {
+ $found = $all_files->{$realfile} || $all_files->{"$realfile/"};
+ }
+ unless ($found) {
+ $self->pointed_hint('doc-base-file-references-missing-file',
+ $item->pointer($position),$file);
+ }
+ }
+ undef @files;
+
+ # Format field.
+ } elsif ($field eq 'Format') {
+ my $format = join($SPACE, @{$vals});
+
+ # trim both ends
+ $format =~ s/^\s+|\s+$//g;
+
+ $format = lc $format;
+ $self->pointed_hint('doc-base-file-unknown-format',
+ $item->pointer($position), $format)
+ unless $known_doc_base_formats{$format};
+ $self->pointed_hint('duplicate-format-in-doc-base',
+ $item->pointer($position), $format)
+ if $sawformats->{$format};
+ $sawformats->{$format} = 1;
+
+ # Save the current format for the later section check.
+ $sawformats->{' *current* '} = $format;
+
+ # Document field.
+ } elsif ($field eq 'Document') {
+ $_ = join($SPACE, @{$vals});
+
+ $self->pointed_hint('doc-base-invalid-document-field',
+ $item->pointer($position), $_)
+ unless /^[a-z0-9+.-]+$/;
+ $self->pointed_hint('doc-base-document-field-ends-in-whitespace',
+ $item->pointer($position))
+ if /[ \t]$/;
+ $self->pointed_hint('doc-base-document-field-not-in-first-line',
+ $item->pointer($position))
+ unless $position == 1;
+
+ # Title field.
+ } elsif ($field eq 'Title') {
+ if (@{$vals}) {
+ my $stag_emitter
+ = $self->spelling_tag_emitter(
+ 'spelling-error-in-doc-base-title-field',
+ $item->pointer($position));
+ check_spelling(
+ $self->data,
+ join($SPACE, @{$vals}),
+ $group->spelling_exceptions,
+ $stag_emitter
+ );
+ check_spelling_picky($self->data, join($SPACE, @{$vals}),
+ $stag_emitter);
+ }
+
+ # Section field.
+ } elsif ($field eq 'Section') {
+ $_ = join($SPACE, @{$vals});
+ unless ($SECTIONS->recognizes($_)) {
+ if (m{^App(?:lication)?s/(.+)$} && $SECTIONS->recognizes($1)) {
+ $self->pointed_hint('doc-base-uses-applications-section',
+ $item->pointer($position), $_);
+ } elsif (m{^(.+)/(?:[^/]+)$} && $SECTIONS->recognizes($1)) {
+ # allows creating a new subsection to a known section
+ } else {
+ $self->pointed_hint('doc-base-unknown-section',
+ $item->pointer($position), $_);
+ }
+ }
+
+ # Abstract field.
+ } elsif ($field eq 'Abstract') {
+ # The three following variables are used for checking if the field is
+ # correctly phrased. We detect if each line (except for the first
+ # line and lines containing single dot) of the field starts with the
+ # same number of spaces, not followed by the same non-space character,
+ # and the number of spaces is > 1.
+ #
+ # We try to match fields like this:
+ # ||Abstract: The Boost web site provides free peer-reviewed portable
+ # || C++ source libraries. The emphasis is on libraries which work
+ # || well with the C++ Standard Library. One goal is to establish
+ #
+ # but not like this:
+ # ||Abstract: This is "Ding"
+ # || * a dictionary lookup program for Unix,
+ # || * DIctionary Nice Grep,
+ my $leadsp; # string with leading spaces from second line
+ my $charafter; # first non-whitespace char of second line
+ my $leadsp_ok = 1; # are spaces OK?
+
+ # Intentionally skipping the first line.
+ for my $idx (1 .. $#{$vals}) {
+ $_ = $vals->[$idx];
+
+ if (/manage\s+online\s+manuals\s.*Debian/) {
+ $self->pointed_hint('doc-base-abstract-field-is-template',
+ $item->pointer($position))
+ unless $pkg eq 'doc-base';
+
+ } elsif (/^(\s+)\.(\s*)$/ and ($1 ne $SPACE or $2)) {
+ $self->pointed_hint(
+ 'doc-base-abstract-field-separator-extra-whitespace',
+ $item->pointer($position - $#{$vals} + $idx)
+ );
+
+ } elsif (!$leadsp && /^(\s+)(\S)/) {
+ # The regexp should always match.
+ ($leadsp, $charafter) = ($1, $2);
+ $leadsp_ok = $leadsp eq $SPACE;
+
+ } elsif (!$leadsp_ok && /^(\s+)(\S)/) {
+ # The regexp should always match.
+ undef $charafter if $charafter && $charafter ne $2;
+ $leadsp_ok = 1
+ if ($1 ne $leadsp) || ($1 eq $leadsp && $charafter);
+ }
+ }
+
+ unless ($leadsp_ok) {
+ $self->pointed_hint(
+ 'doc-base-abstract-might-contain-extra-leading-whitespace',
+ $item->pointer($position));
+ }
+
+ # Check spelling.
+ if (@{$vals}) {
+ my $stag_emitter
+ = $self->spelling_tag_emitter(
+ 'spelling-error-in-doc-base-abstract-field',
+ $item->pointer($position));
+ check_spelling(
+ $self->data,
+ join($SPACE, @{$vals}),
+ $group->spelling_exceptions,
+ $stag_emitter
+ );
+ check_spelling_picky($self->data, join($SPACE, @{$vals}),
+ $stag_emitter);
+ }
+ }
+
+ return;
+}
+
+# Checks the section of the doc-base control file. Tries to find required
+# fields missing in the section.
+sub check_doc_base_file_section {
+ my ($self, $item, $position, $sawfields, $sawformats, $knownfields) = @_;
+
+ $self->pointed_hint('doc-base-file-no-format', $item->pointer($position))
+ if ((defined $sawfields->{'Files'} || defined $sawfields->{'Index'})
+ && !(defined $sawfields->{'Format'}));
+
+ # The current format is set by check_doc_base_field.
+ if ($sawfields->{'Format'}) {
+ my $format = $sawformats->{' *current* '};
+ $self->pointed_hint('doc-base-file-no-index',$item->pointer($position))
+ if ( $format
+ && ($format eq 'html' || $format eq 'info')
+ && !$sawfields->{'Index'});
+ }
+ for my $field (sort keys %{$knownfields}) {
+ $self->pointed_hint('doc-base-file-lacks-required-field',
+ $item->pointer($position), $field)
+ if ($knownfields->{$field} == 1 && !$sawfields->{$field});
+ }
+
+ return;
+}
+
+# Add file and link to $all_files and $all_links. Note that both files and
+# links have to include a leading /.
+sub add_file_link_info {
+ my ($processable, $file, $all_files, $all_links) = @_;
+
+ my $link = $processable->installed->lookup($file)->link;
+ my $ishard = $processable->installed->lookup($file)->is_hardlink;
+
+ # make name absolute
+ $file = $SLASH . $file
+ unless $file =~ m{^/};
+
+ $file =~ s{/+}{/}g; # remove duplicated `/'
+ $all_files->{$file} = 1;
+
+ if (length $link) {
+
+ $link = $DOT . $SLASH . $link
+ if $link !~ m{^/};
+
+ if ($ishard) {
+ $link =~ s{^\./}{/};
+ } elsif ($link !~ m{^/}) { # not absolute link
+ $link
+ = $SLASH
+ . $link; # make sure link starts with '/'
+ $link =~ s{/+\./+}{/}g; # remove all /./ parts
+ my $dcount = 1;
+ while ($link =~ s{^/+\.\./+}{/}) { #\ count & remove
+ $dcount++; #/ any leading /../ parts
+ }
+ my $f = $file;
+ while ($dcount--) { #\ remove last $dcount
+ $f=~ s{/[^/]*$}{}; #/ path components from $file
+ }
+ $link
+ = $f. $link; # now we should have absolute link
+ }
+ $all_links->{$file} = $link unless ($link eq $file);
+ }
+
+ return;
+}
+
+# Dereference all symlinks in file.
+sub delink {
+ my ($file, $all_links) = @_;
+
+ $file =~ s{/+}{/}g; # remove duplicated '/'
+ return $file
+ unless %{$all_links}; # package doesn't symlinks
+
+ my $p1 = $EMPTY;
+ my $p2 = $file;
+ my %used_links;
+
+ # In the loop below we split $file into two parts on each '/' until
+ # there's no remaining slashes. We try substituting the first part with
+ # corresponding symlink and if it succeeds, we start the procedure from
+ # beginning.
+ #
+ # Example:
+ # Let $all_links{"/a/b"} == "/d", and $file == "/a/b/c"
+ # Then 0) $p1 == "", $p2 == "/a/b/c"
+ # 1) $p1 == "/a", $p2 == "/b/c"
+ # 2) $p1 == "/a/b", $p2 == "/c" ; substitute "/d" for "/a/b"
+ # 3) $p1 == "", $p2 == "/d/c"
+ # 4) $p1 == "/d", $p2 == "/c"
+ # 5) $p1 == "/d/c", $p2 == ""
+ #
+ # Note that the algorithm supposes, that
+ # i) $all_links{$X} != $X for each $X
+ # ii) both keys and values of %all_links start with '/'
+
+ while (($p2 =~ s{^(/[^/]*)}{}g) > 0) {
+ $p1 .= $1;
+ if (defined $all_links->{$p1}) {
+ return '!!! SYMLINK LOOP !!!' if defined $used_links{$p1};
+ $p2 = $all_links->{$p1} . $p2;
+ $p1 = $EMPTY;
+ $used_links{$p1} = 1;
+ }
+ }
+
+ # After the loop $p2 should be empty and $p1 should contain the target
+ # file. In some rare cases when $file contains no slashes, $p1 will be
+ # empty and $p2 will contain the result (which will be equal to $file).
+ return $p1 ne $EMPTY ? $p1 : $p2;
+}
+
+sub check_script {
+ my ($self, $item, $pres) = @_;
+
+ my $pkg = $self->processable->name;
+
+ my ($no_check_menu, $no_check_installdocs);
+
+ # control files are regular files and not symlinks, pipes etc.
+ return
+ unless defined $item;
+
+ return
+ if $item->is_symlink;
+
+ return
+ unless $item->is_open_ok;
+
+ # nothing to do for ELF
+ return
+ if $item->is_elf;
+
+ my $interpreter = $item->interpreter || 'unknown';
+
+ if ($item->is_shell_script) {
+ $interpreter = 'sh';
+
+ } elsif ($interpreter =~ m{^/usr/bin/perl}) {
+ $interpreter = 'perl';
+ }
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+ # skip comments
+ $line =~ s/\#.*$//;
+
+ ##
+ # update-menus will satisfy the checks that the menu file
+ # installed is properly used
+ ##
+
+ # does the script check whether update-menus exists?
+ $pres->{'checks-for-updatemenus'} = $item->pointer($position)
+ if $line =~ /-x\s+\S*update-menus/
+ || $line =~ /(?:which|type)\s+update-menus/
+ || $line =~ /command\s+.*?update-menus/;
+
+ # does the script call update-menus?
+ # TODO this regex-magic should be moved to some lib for checking
+ # whether a certain word is likely called as command... --Jeroen
+ if (
+ $line =~m{ (?:^\s*|[;&|]\s*|(?:then|do|exec)\s+)
+ (?:\/usr\/bin\/)?update-menus
+ (?:\s|[;&|<>]|\Z)}xsm
+ ) {
+ # yes, it does.
+ $pres->{'calls-updatemenus'} = $item->pointer($position);
+
+ # checked first?
+ if (not $pres->{'checks-for-updatemenus'} and $pkg ne 'menu') {
+ $self->pointed_hint(
+'maintainer-script-does-not-check-for-existence-of-updatemenus',
+ $item->pointer($position)
+ ) unless $no_check_menu++;
+ }
+ }
+
+ # does the script check whether install-docs exists?
+ $pres->{'checks-for-installdocs'} = $item->pointer($position)
+ if $line =~ s/-x\s+\S*install-docs//
+ || $line =~/(?:which|type)\s+install-docs/
+ || $line =~ s/command\s+.*?install-docs//;
+
+ # does the script call install-docs?
+ if (
+ $line =~ m{ (?:^\s*|[;&|]\s*|(?:then|do)\s+)
+ (?:\/usr\/sbin\/)?install-docs
+ (?:\s|[;&|<>]|\Z) }xsm
+ ) {
+ # yes, it does. Does it remove or add a doc?
+ if ($line =~ /install-docs\s+(?:-r|--remove)\s/) {
+ $pres->{'calls-installdocs-r'} = $item->pointer($position);
+ } else {
+ $pres->{'calls-installdocs'} = $item->pointer($position);
+ }
+
+ # checked first?
+ if (not $pres->{'checks-for-installdocs'}) {
+ $self->pointed_hint(
+'maintainer-script-does-not-check-for-existence-of-installdocs',
+ $item->pointer($position)
+ ) unless $no_check_installdocs++;
+ }
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close($fd);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Mimeinfo.pm b/lib/Lintian/Check/Mimeinfo.pm
new file mode 100644
index 0000000..f24b73d
--- /dev/null
+++ b/lib/Lintian/Check/Mimeinfo.pm
@@ -0,0 +1,61 @@
+# mimeinfo -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Mimeinfo;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->name =~ m{^usr/share/applications/mimeinfo.cache(?:\.gz)?$}){
+ $self->pointed_hint('package-contains-mimeinfo.cache-file',
+ $item->pointer);
+
+ }elsif ($item->name =~ m{^usr/share/mime/.+}) {
+
+ if ($item->name =~ m{^usr/share/mime/[^/]+$}) {
+ $self->pointed_hint('package-contains-mime-cache-file',
+ $item->pointer);
+
+ } elsif ($item->name !~ m{^usr/share/mime/packages/}) {
+ $self->pointed_hint(
+ 'package-contains-mime-file-outside-package-dir',
+ $item->pointer);
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Modprobe.pm b/lib/Lintian/Check/Modprobe.pm
new file mode 100644
index 0000000..f9af6c7
--- /dev/null
+++ b/lib/Lintian/Check/Modprobe.pm
@@ -0,0 +1,61 @@
+# modprobe -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Modprobe;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(uniq);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ( $item->name =~ m{^etc/modprobe\.d/ }x
+ && $item->name !~ m{ [.]conf $}x
+ && !$item->is_dir) {
+
+ $self->pointed_hint('non-conf-file-in-modprobe.d', $item->pointer);
+
+ } elsif ($item->name =~ m{^ etc/modprobe[.]d/ }x
+ || $item->name =~ m{^ etc/modules-load\.d/ }x) {
+
+ my @obsolete = ($item->bytes =~ m{^ \s* ( install | remove ) }gmx);
+ $self->pointed_hint('obsolete-command-in-modprobe.d-file',
+ $item->pointer, $_)
+ for uniq @obsolete;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Nmu.pm b/lib/Lintian/Check/Nmu.pm
new file mode 100644
index 0000000..a758728
--- /dev/null
+++ b/lib/Lintian/Check/Nmu.pm
@@ -0,0 +1,193 @@
+# nmu -- lintian check script -*- perl -*-
+
+# Copyright (C) 2004 Jeroen van Wolffelaar
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Nmu;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any);
+use List::Util qw(first);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ my $changelog_mentions_nmu = 0;
+ my $changelog_mentions_local = 0;
+ my $changelog_mentions_qa = 0;
+ my $changelog_mentions_team_upload = 0;
+
+ my $debian_dir = $processable->patched->resolve_path('debian/');
+
+ my $chf;
+ $chf = $debian_dir->child('changelog') if $debian_dir;
+
+ # This isn't really an NMU check, but right now no other check
+ # looks at debian/changelog in source packages. Catch a
+ # debian/changelog file that's a symlink.
+ $self->pointed_hint('changelog-is-symlink', $chf->pointer)
+ if $chf && $chf->is_symlink;
+
+ return
+ unless $processable->changelog;
+
+ # Get some data from the changelog file.
+ my ($entry) = @{$processable->changelog->entries};
+
+ my $pointer = $chf->pointer($entry->position);
+
+ my $uploader = canonicalize($entry->Maintainer // $EMPTY);
+
+ # trim both ends
+ $self->pointed_hint('extra-whitespace-around-name-in-changelog-trailer',
+ $pointer)
+ if $uploader =~ s/^\s+|\s+$//g;
+
+ my $changes = $entry->Changes;
+ $changes =~ s/^(\s*\n)+//;
+ my $firstline = first { /^\s*\*/ } split(/\n/, $changes);
+
+ # Check the first line for QA, NMU or team upload mentions.
+ if ($firstline) {
+ local $_ = $firstline;
+ if (/\bnmu\b/i or /non-maintainer upload/i or m/LowThresholdNMU/i) {
+ unless (
+ m{
+ (?:ackno|\back\b|confir|incorporat).*
+ (?:\bnmu\b|non-maintainer)}xi
+ ) {
+ $changelog_mentions_nmu = 1;
+ }
+ }
+ $changelog_mentions_local = 1 if /\blocal\s+package\b/i;
+ $changelog_mentions_qa = 1 if /orphan/i or /qa (?:group )?upload/i;
+ $changelog_mentions_team_upload = 1 if /team upload/i;
+ }
+
+ # If the version field is missing, assume it to be a native,
+ # maintainer upload as it is probably the most likely case.
+ my $version = $processable->fields->value('Version') || '0-1';
+ my $maintainer= canonicalize($processable->fields->value('Maintainer'));
+ my $uploaders = $processable->fields->value('Uploaders');
+
+ my $version_nmuness = 0;
+ my $version_local = 0;
+ my $upload_is_backport = $version =~ m/~bpo(\d+)\+(\d+)$/;
+ my $upload_is_stable_update = $version =~ m/~deb(\d+)u(\d+)$/;
+
+ if ($version =~ /-[^.-]+(\.[^.-]+)?(\.[^.-]+)?$/) {
+ $version_nmuness = 1 if defined $1;
+ $version_nmuness = 2 if defined $2;
+ }
+ if ($version =~ /\+nmu\d+$/) {
+ $version_nmuness = 1;
+ }
+ if ($version =~ /\+b\d+$/) {
+ $version_nmuness = 2;
+ }
+ if ($version =~ /local/i) {
+ $version_local = 1;
+ }
+
+ my $upload_is_nmu = $uploader ne $maintainer;
+
+ my @uploaders = map { canonicalize($_) } split />\K\s*,\s*/,$uploaders;
+ $upload_is_nmu = 0 if any { $_ eq $uploader } @uploaders;
+
+ # If the changelog entry is missing a maintainer (eg. "-- <blank>")
+ # assume it's an upload still work in progress.
+ $upload_is_nmu = 0 if not $uploader;
+
+ if ($maintainer =~ /packages\@qa.debian.org/) {
+
+ $self->pointed_hint('uploaders-in-orphan', $pointer)
+ if $processable->fields->declares('Uploaders');
+
+ $self->pointed_hint('qa-upload-has-incorrect-version-number',
+ $pointer, $version)
+ if $version_nmuness == 1;
+
+ $self->pointed_hint('no-qa-in-changelog', $pointer)
+ unless $changelog_mentions_qa;
+
+ } elsif ($changelog_mentions_team_upload) {
+
+ $self->pointed_hint('team-upload-has-incorrect-version-number',
+ $pointer, $version)
+ if $version_nmuness == 1;
+
+ $self->pointed_hint('unnecessary-team-upload', $pointer)
+ unless $upload_is_nmu;
+
+ } else {
+ # Local packages may be either NMUs or not.
+ unless ($changelog_mentions_local || $version_local) {
+
+ $self->pointed_hint('no-nmu-in-changelog', $pointer)
+ if !$changelog_mentions_nmu && $upload_is_nmu;
+
+ $self->pointed_hint('source-nmu-has-incorrect-version-number',
+ $pointer, $version)
+ if $upload_is_nmu
+ && $version_nmuness != 1
+ && !$upload_is_stable_update
+ && !$upload_is_backport;
+ }
+
+ $self->pointed_hint('nmu-in-changelog', $pointer)
+ if $changelog_mentions_nmu && !$upload_is_nmu;
+
+ $self->pointed_hint('maintainer-upload-has-incorrect-version-number',
+ $pointer, $version)
+ if !$upload_is_nmu && $version_nmuness;
+ }
+
+ return;
+}
+
+# Canonicalize a maintainer address with respect to case. E-mail addresses
+# are case-insensitive in the right-hand side.
+sub canonicalize {
+ my ($maintainer) = @_;
+
+ $maintainer =~ s/<([^>\@]+\@)([\w.-]+)>/<$1\L$2>/;
+
+ return $maintainer;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/ObsoleteSites.pm b/lib/Lintian/Check/ObsoleteSites.pm
new file mode 100644
index 0000000..976cdb2
--- /dev/null
+++ b/lib/Lintian/Check/ObsoleteSites.pm
@@ -0,0 +1,96 @@
+# obsolete-sites -- lintian check script -*- perl -*-
+
+# Copyright (C) 2015 Axel Beckert <abe@debian.org>
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::ObsoleteSites;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(any);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my @interesting_files = qw(
+ control
+ copyright
+ watch
+ upstream
+ upstream/metadata
+ upstream-metadata.yaml
+);
+
+sub visit_patched_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_regular_file;
+
+ $self->search_for_obsolete_sites($item)
+ if any { $item->name =~ m{^ debian/$_ $}x } @interesting_files;
+
+ return;
+}
+
+sub search_for_obsolete_sites {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_open_ok;
+
+ my $OBSOLETE_SITES= $self->data->load('obsolete-sites/obsolete-sites');
+
+ my $bytes = $item->bytes;
+
+ # strip comments
+ $bytes =~ s/^ \s* [#] .* $//gmx;
+
+ for my $site ($OBSOLETE_SITES->all) {
+
+ if ($bytes
+ =~ m{ (\w+:// (?: [\w.]* [.] )? \Q$site\E [/:] [^\s"<>\$]* ) }ix) {
+
+ my $url = $1;
+ $self->pointed_hint('obsolete-url-in-packaging', $item->pointer,
+ $url);
+ }
+ }
+
+ if ($bytes =~ m{ (ftp:// (?:ftp|security) [.]debian[.]org) }ix) {
+
+ my $url = $1;
+ $self->pointed_hint('obsolete-url-in-packaging', $item->pointer, $url);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Origtar.pm b/lib/Lintian/Check/Origtar.pm
new file mode 100644
index 0000000..47de793
--- /dev/null
+++ b/lib/Lintian/Check/Origtar.pm
@@ -0,0 +1,55 @@
+# origtar -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2008 Bernhard R. Link
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Origtar;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ return
+ if $processable->native;
+
+ my @origfiles = @{$processable->orig->sorted_list};
+
+ $self->hint('empty-upstream-sources')
+ unless @origfiles;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Pe.pm b/lib/Lintian/Check/Pe.pm
new file mode 100644
index 0000000..d5514d5
--- /dev/null
+++ b/lib/Lintian/Check/Pe.pm
@@ -0,0 +1,113 @@
+# pe -- lintian check script -*- perl -*-
+
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Pe;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+
+const my $MAIN_HEADER => 0x3c;
+const my $MAIN_HEADER_LENGTH_WORD_SIZE => 4;
+const my $OPTIONAL_HEADER => 0x18;
+const my $DLL_CHARACTERISTICS => 0x46;
+const my $ASLR_FLAG => 0x40;
+const my $DEP_NX_FLAG => 0x100;
+const my $UNSAFE_SEH_FLAG => 0x400;
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->file_type =~ /^PE32\+? executable/;
+
+ return
+ unless $item->is_open_ok;
+
+ my $buf;
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ try {
+ # offset to main header
+ seek($fd, $MAIN_HEADER, 0)
+ or die encode_utf8("seek: $!");
+
+ read($fd, $buf, $MAIN_HEADER_LENGTH_WORD_SIZE)
+ or die encode_utf8("read: $!");
+
+ my $pe_offset = unpack('V', $buf);
+
+ # 0x18 is index to "Optional Header"; 0x46 to DLL Characteristics
+ seek($fd, $pe_offset + $OPTIONAL_HEADER + $DLL_CHARACTERISTICS, 0)
+ or die encode_utf8("seek: $!");
+
+ # get DLLCharacteristics value
+ read($fd, $buf, 2)
+ or die encode_utf8("read: $!");
+
+ } catch {
+ die $@;
+ }
+
+ my $characteristics = unpack('v', $buf);
+ my %features = (
+ 'ASLR' => $characteristics & $ASLR_FLAG,
+ 'DEP/NX' => $characteristics & $DEP_NX_FLAG,
+ 'SafeSEH' => ~$characteristics & $UNSAFE_SEH_FLAG, # note negation
+ );
+
+ # Don't check for the x86-specific "SafeSEH" feature for code
+ # that is JIT-compiled by the Mono runtime. (#926334)
+ delete $features{'SafeSEH'}
+ if $item->file_type =~ / Mono\/.Net assembly, /;
+
+ my @missing = grep { !$features{$_} } sort keys %features;
+
+ $self->pointed_hint('portable-executable-missing-security-features',
+ $item->pointer,join($SPACE, @missing))
+ if scalar @missing;
+
+ close $fd;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Script/Deprecated/Chown.pm b/lib/Lintian/Check/Script/Deprecated/Chown.pm
new file mode 100644
index 0000000..e640e17
--- /dev/null
+++ b/lib/Lintian/Check/Script/Deprecated/Chown.pm
@@ -0,0 +1,96 @@
+# script/deprecated/chown -- lintian check script -*- perl -*-
+
+# Copyright (C) 2022 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Script::Deprecated::Chown;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Unicode::UTF8 qw(valid_utf8 encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub check_item {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->is_script;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ next
+ if $line =~ /^#/;
+
+ next
+ unless length $line;
+
+ if ($line =~ m{ \b chown \s+ (?: -\S+ \s+ )* ( \S+ [.] \S+ ) \b }x) {
+
+ my $ownership = $1;
+
+ $self->pointed_hint('chown-with-dot', $item->pointer($position),
+ $ownership);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ $self->check_item($item);
+
+ return;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->check_item($item);
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Script/Syntax.pm b/lib/Lintian/Check/Script/Syntax.pm
new file mode 100644
index 0000000..20188f1
--- /dev/null
+++ b/lib/Lintian/Check/Script/Syntax.pm
@@ -0,0 +1,224 @@
+# script/syntax -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Script::Syntax;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $MAXIMUM_LINES_ANALYZED => 54;
+
+# exclude some shells. zsh -n is broken, see #485885
+const my %SYNTAX_CHECKERS => (
+ sh => [qw{/bin/dash -n}],
+ bash => [qw{/bin/bash -n}]
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # Consider /usr/src/ scripts as "documentation"
+ # - packages containing /usr/src/ tend to be "-source" .debs
+ # and usually come with overrides
+ # no checks necessary at all for scripts in /usr/share/doc/
+ # unless they are examples
+ return
+ if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/})
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ # Syntax-check most shell scripts, but don't syntax-check
+ # scripts that end in .dpatch. bash -n doesn't stop checking
+ # at exit 0 and goes on to blow up on the patch itself.
+ $self->pointed_hint('shell-script-fails-syntax-check',$item->pointer)
+ if $self->fails_syntax_check($item)
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/}
+ && $item->name !~ /\.dpatch$/
+ && $item->name !~ /\.erb$/;
+
+ $self->pointed_hint('example-shell-script-fails-syntax-check',
+ $item->pointer)
+ if $self->fails_syntax_check($item)
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/}
+ && $item->name !~ /\.dpatch$/
+ && $item->name !~ /\.erb$/;
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('maintainer-shell-script-fails-syntax-check',
+ $item->pointer)
+ if $self->fails_syntax_check($item);
+
+ return;
+}
+
+sub fails_syntax_check {
+ my ($self, $item) = @_;
+
+ return 0
+ unless length $item->interpreter;
+
+ my $basename = basename($item->interpreter);
+
+ my @command;
+
+ # "Perl doesn't distinguish between restricted hashes and readonly hashes."
+ # https://metacpan.org/pod/Const::Fast#CAVEATS
+ @command = @{$SYNTAX_CHECKERS{$basename}}
+ if exists $SYNTAX_CHECKERS{$basename};
+
+ return 0
+ unless @command;
+
+ my $program = $command[0];
+ return 0
+ unless length $program
+ && -x $program;
+
+ return 0
+ unless $item->is_open_ok;
+
+ return 0
+ if script_looks_dangerous($item);
+
+ # Given an interpreter and a file, run the interpreter on that file with the
+ # -n option to check syntax, discarding output and returning the exit status.
+ safe_qx(@command, $item->unpacked_path);
+ my $failed = $?;
+
+ return $failed;
+}
+
+# Returns non-zero if the given file is not actually a shell script,
+# just looks like one.
+sub script_looks_dangerous {
+ my ($item) = @_;
+
+ my $result = 0;
+ my $shell_variable_name = '0';
+ my $backgrounded = 0;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ next
+ if $line =~ /^#/;
+
+ next
+ unless length $line;
+
+ last
+ if $position >= $MAXIMUM_LINES_ANALYZED;
+
+ if (
+ $line =~ m<
+ # the exec should either be "eval"ed or a new statement
+ (?:^\s*|\beval\s*[\'\"]|(?:;|&&|\b(?:then|else))\s*)
+
+ # eat anything between the exec and $0
+ exec\s*.+\s*
+
+ # optionally quoted executable name (via $0)
+ .?\$$shell_variable_name.?\s*
+
+ # optional "end of options" indicator
+ (?:--\s*)?
+
+ # Match expressions of the form '${1+$@}', '${1:+"$@"',
+ # '"${1+$@', "$@", etc where the quotes (before the dollar
+ # sign(s)) are optional and the second (or only if the $1
+ # clause is omitted) parameter may be $@ or $*.
+ #
+ # Finally the whole subexpression may be omitted for scripts
+ # which do not pass on their parameters (i.e. after re-execing
+ # they take their parameters (and potentially data) from stdin
+ .?(?:\$[{]1:?\+.?)?(?:\$[\@\*])?>x
+ ) {
+ $result = 1;
+
+ last;
+
+ } elsif ($line =~ /^\s*(\w+)=\$0;/) {
+ $shell_variable_name = $1;
+
+ } elsif (
+ $line =~ m<
+ # Match scripts which use "foo $0 $@ &\nexec true\n"
+ # Program name
+ \S+\s+
+
+ # As above
+ .?\$$shell_variable_name.?\s*
+ (?:--\s*)?
+ .?(?:\$[{]1:?\+.?)?(?:\$[\@\*])?.?\s*\&>x
+ ) {
+
+ $backgrounded = 1;
+
+ } elsif (
+ $backgrounded
+ && $line =~ m{
+ # the exec should either be "eval"ed or a new statement
+ (?:^\s*|\beval\s*[\'\"]|(?:;|&&|\b(?:then|else))\s*)
+ exec\s+true(?:\s|\Z)}x
+ ) {
+
+ $result = 1;
+ last;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return $result;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Scripts.pm b/lib/Lintian/Check/Scripts.pm
new file mode 100644
index 0000000..5539208
--- /dev/null
+++ b/lib/Lintian/Check/Scripts.pm
@@ -0,0 +1,1070 @@
+# scripts -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Scripts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::SomeUtils qw(any none);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Relation;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $AT_SIGN => q{@};
+const my $ASTERISK => q{*};
+const my $DOT => q{.};
+const my $DOUBLE_QUOTE => q{"};
+const my $NOT_EQUAL => q{!=};
+
+const my $BAD_MAINTAINER_COMMAND_FIELDS => 5;
+const my $UNVERSIONED_INTERPRETER_FIELDS => 2;
+const my $VERSIONED_INTERPRETER_FIELDS => 5;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# This is a map of all known interpreters. The key is the interpreter
+# name (the binary invoked on the #! line). The value is an anonymous
+# array of two elements. The first argument is the path on a Debian
+# system where that interpreter would be installed. The second
+# argument is the dependency that provides that interpreter.
+#
+# $INTERPRETERS maps names of (unversioned) interpreters to the path
+# they are installed and what package to depend on to use them.
+#
+has INTERPRETERS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %unversioned;
+
+ my $data
+ = $self->data->load('scripts/interpreters',qr/ \s* => \s* /msx);
+
+ for my $interpreter ($data->all) {
+
+ my $remainder = $data->value($interpreter);
+
+ my ($folder, $prerequisites)= split(/ \s* , \s* /msx,
+ $remainder, $UNVERSIONED_INTERPRETER_FIELDS);
+
+ $prerequisites //= $EMPTY;
+
+ $unversioned{$interpreter} = {
+ folder => $folder,
+ prerequisites => $prerequisites
+ };
+ }
+
+ return \%unversioned;
+ }
+);
+
+# The more complex case of interpreters that may have a version number.
+#
+# This is a hash from the base interpreter name to a list. The base
+# interpreter name may appear by itself or followed by some combination of
+# dashes, digits, and periods.
+#
+# The list contains the following values:
+# [<path>, <dependency-relation>, <regex>, <dependency-template>, <version-list>]
+#
+# Their meaning is documented in Lintian's scripts/versioned-interpreters
+# file, though they are ordered differently and there are a few differences
+# as described below:
+#
+# * <regex> has been passed through qr/^<value>$/
+# * If <dependency-relation> was left out, it has been substituted by the
+# interpreter.
+# * The magic values of <dependency-relation> are represented as:
+# @SKIP_UNVERSIONED@ -> undef (i.e the undefined value)
+# * <version-list> has been split into a list of versions.
+# (e.g. "1.6 1.8" will be ["1.6", "1.8"])
+#
+# A full example is:
+#
+# data:
+# lua => /usr/bin, lua([\d.]+), 'lua$1', 40 50 5.1
+#
+# $VERSIONED_INTERPRETERS->value ('lua') is
+# [ '/usr/bin', 'lua', qr/^lua([\d.]+)$/, 'lua$1', ["40", "50", "5.1"] ]
+#
+has VERSIONED_INTERPRETERS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %versioned;
+
+ my $data = $self->data->load('scripts/versioned-interpreters',
+ qr/ \s* => \s* /msx);
+
+ for my $interpreter ($data->all) {
+
+ my $remainder = $data->value($interpreter);
+
+ my ($folder, $pattern, $template, $version_list, $prerequisites)
+ = split(/ \s* , \s* /msx,
+ $remainder, $VERSIONED_INTERPRETER_FIELDS);
+
+ my @versions = split(/ \s+ /msx, $version_list);
+ $prerequisites //= $EMPTY;
+
+ if ($prerequisites eq $AT_SIGN . 'SKIP_UNVERSIONED' . $AT_SIGN) {
+ $prerequisites = undef;
+
+ } elsif ($prerequisites =~ / @ /msx) {
+ die encode_utf8(
+"Unknown magic value $prerequisites for versioned interpreter $interpreter"
+ );
+ }
+
+ $versioned{$interpreter} = {
+ folder => $folder,
+ prerequisites => $prerequisites,
+ regex => qr/^$pattern$/,
+ template => $template,
+ versions => \@versions
+ };
+ }
+
+ return \%versioned;
+ }
+);
+
+# When detecting commands inside shell scripts, use this regex to match the
+# beginning of the command rather than checking whether the command is at the
+# beginning of a line.
+const my $LEADING_PATTERN=>
+'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
+const my $LEADING_REGEX => qr/$LEADING_PATTERN/;
+
+#forbidden command in maintainer scripts
+has BAD_MAINTAINER_COMMANDS => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %forbidden;
+
+ my $data = $self->data->load('scripts/maintainer-script-bad-command',
+ qr/\s*\~\~/);
+
+ for my $key ($data->all) {
+
+ my $value = $data->value($key);
+
+ my ($in_cat,$in_auto,$package_include_pattern,
+ $script_include_pattern,$command_pattern)
+ = split(/ \s* ~~ /msx, $value,$BAD_MAINTAINER_COMMAND_FIELDS);
+
+ die encode_utf8(
+ "Syntax error in scripts/maintainer-script-bad-command: $.")
+ if any { !defined }(
+ $in_cat,$in_auto,$package_include_pattern,
+ $script_include_pattern,$command_pattern
+ );
+
+ # trim both ends
+ $in_cat =~ s/^\s+|\s+$//g;
+ $in_auto =~ s/^\s+|\s+$//g;
+ $package_include_pattern =~ s/^\s+|\s+$//g;
+ $script_include_pattern =~ s/^\s+|\s+$//g;
+
+ $package_include_pattern ||= '\a\Z';
+
+ $script_include_pattern ||= $DOT . $ASTERISK;
+
+ $command_pattern=~ s/\$[{]LEADING_PATTERN[}]/$LEADING_PATTERN/;
+
+ $forbidden{$key} = {
+ ignore_automatic_sections => !!$in_auto,
+ in_cat_string => !!$in_cat,
+ package_exclude_regex => qr/$package_include_pattern/x,
+ script_include_regex => qr/$script_include_pattern/x,
+ command_pattern => $command_pattern,
+ };
+ }
+
+ return \%forbidden;
+ }
+);
+
+# Appearance of one of these regexes in a maintainer script means that there
+# must be a dependency (or pre-dependency) on the given package. The tag
+# reported is maintainer-script-needs-depends-on-%s, so be sure to update
+# scripts.desc when adding a new rule.
+my %prerequisite_by_command_pattern = (
+ '\badduser\s' => 'adduser',
+ '\bgconf-schemas\s' => 'gconf2',
+ '\bupdate-inetd\s' =>
+'update-inetd | inet-superserver | openbsd-inetd | inetutils-inetd | rlinetd | xinetd',
+ '\bucf\s' => 'ucf',
+ '\bupdate-xmlcatalog\s' => 'xml-core',
+ '\bupdate-fonts-(?:alias|dir|scale)\s' => 'xfonts-utils',
+);
+
+# no dependency for install-menu, because the menu package specifically
+# says not to depend on it.
+has all_prerequisites => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $all_prerequisites
+ = $self->processable->relation('all')
+ ->logical_and($self->processable->relation('Provides'),
+ $self->processable->name);
+
+ return $all_prerequisites;
+ }
+);
+
+has strong_prerequisites => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $strong_prerequisites = $self->processable->relation('strong');
+
+ return $strong_prerequisites;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_script;
+
+ # Consider /usr/src/ scripts as "documentation"
+ # - packages containing /usr/src/ tend to be "-source" .debs
+ # and usually comes with overrides for most of the checks
+ # below.
+ # Supposedly, they could be checked as examples, but there is
+ # a risk that the scripts need substitution to be complete
+ # (so, syntax checking is not as reliable).
+
+ # no checks necessary at all for scripts in /usr/share/doc/
+ # unless they are examples
+ return
+ if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/})
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ my $basename = basename($item->interpreter);
+
+ # Ignore Python scripts that are shipped under dist-packages; these
+ # files aren't supposed to be called as scripts.
+ return
+ if $basename eq 'python'
+ && $item->name =~ m{^usr/lib/python3/dist-packages/};
+
+ # allow exception for .in files that have stuff like #!@PERL@
+ return
+ if $item->name =~ /\.in$/
+ && $item->interpreter =~ /^(\@|<\<)[A-Z_]+(\@|>\>)$/;
+
+ my $is_absolute = ($item->interpreter =~ m{^/} || $item->calls_env);
+
+ # As a special-exception, Policy 10.4 states that Perl scripts must use
+ # /usr/bin/perl directly and not via /usr/bin/env, etc.
+ $self->pointed_hint(
+ 'incorrect-path-for-interpreter',
+ $item->pointer,'/usr/bin/env perl',
+ $NOT_EQUAL, '/usr/bin/perl'
+ )
+ if $item->calls_env
+ && $item->interpreter eq 'perl'
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint(
+ 'example-incorrect-path-for-interpreter',
+ $item->pointer,'/usr/bin/env perl',
+ $NOT_EQUAL, '/usr/bin/perl'
+ )
+ if $item->calls_env
+ && $item->interpreter eq 'perl'
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ # Skip files that have the #! line, but are not executable and
+ # do not have an absolute path and are not in a bin/ directory
+ # (/usr/bin, /bin etc). They are probably not scripts after
+ # all.
+ return
+ if ( $item->name !~ m{(?:bin/|etc/init\.d/)}
+ && (!$item->is_file || !$item->is_executable)
+ && !$is_absolute
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/});
+
+ # Example directories sometimes contain Perl libraries, and
+ # some people use initial lines like #!perl or #!python to
+ # provide editor hints, so skip those too if they're not
+ # executable. Be conservative here, since it's not uncommon
+ # for people to both not set examples executable and not fix
+ # the path and we want to warn about that.
+ return
+ if ( $item->name =~ /\.pm\z/
+ && (!$item->is_file || !$item->is_executable)
+ && !$is_absolute
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/});
+
+ # Skip upstream source code shipped in /usr/share/cargo/registry/
+ return
+ if $item->name =~ m{^usr/share/cargo/registry/};
+
+ if ($item->interpreter eq $EMPTY) {
+
+ $self->pointed_hint('script-without-interpreter', $item->pointer)
+ if $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-script-without-interpreter',
+ $item->pointer)
+ if $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ return;
+ }
+
+ # Either they use an absolute path or they use '/usr/bin/env interp'.
+ $self->pointed_hint('interpreter-not-absolute', $item->pointer,
+ $item->interpreter)
+ if !$is_absolute
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-interpreter-not-absolute',
+ $item->pointer,$item->interpreter)
+ if !$is_absolute
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ my $bash_completion_regex= qr{^usr/share/bash-completion/completions/.*};
+
+ $self->pointed_hint('script-not-executable', $item->pointer)
+ if (!$item->is_file || !$item->is_executable)
+ && $item->name !~ m{^usr/(?:lib|share)/.*\.pm}
+ && $item->name !~ m{^usr/(?:lib|share)/.*\.py}
+ && $item->name !~ m{^usr/(?:lib|share)/ruby/.*\.rb}
+ && $item->name !~ m{^usr/share/debconf/confmodule(?:\.sh)?$}
+ && $item->name !~ /\.in$/
+ && $item->name !~ /\.erb$/
+ && $item->name !~ /\.ex$/
+ && $item->name ne 'etc/init.d/skeleton'
+ && $item->name !~ m{^etc/menu-methods}
+ && $item->name !~ $bash_completion_regex
+ && $item->name !~ m{^etc/X11/Xsession\.d}
+ && $item->name !~ m{^usr/share/doc/}
+ && $item->name !~ m{^usr/src/};
+
+ return
+ unless $item->is_open_ok;
+
+ # Try to find the expected path of the script to check. First
+ # check $INTERPRETERS and %versioned_interpreters. If not
+ # found there, see if it ends in a version number and the base
+ # is found in $VERSIONED_INTERPRETERS
+ my $interpreter_data = $self->INTERPRETERS->{$basename};
+
+ my $versioned = 0;
+ unless (defined $interpreter_data) {
+
+ $interpreter_data = $self->VERSIONED_INTERPRETERS->{$basename};
+
+ if (!defined $interpreter_data && $basename =~ /^(.*[^\d.-])-?[\d.]+$/)
+ {
+ $interpreter_data = $self->VERSIONED_INTERPRETERS->{$1};
+ undef $interpreter_data
+ unless $interpreter_data
+ && $basename =~ /$interpreter_data->{regex}/;
+ }
+
+ $versioned = 1
+ if defined $interpreter_data;
+ }
+
+ if (defined $interpreter_data) {
+ my $expected = $interpreter_data->{folder} . $SLASH . $basename;
+
+ my @context = ($item->interpreter, $NOT_EQUAL, $expected);
+
+ $self->pointed_hint('wrong-path-for-interpreter', $item->pointer,
+ @context)
+ if $item->interpreter ne $expected
+ && !$item->calls_env
+ && $expected ne '/usr/bin/env perl'
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-wrong-path-for-interpreter',
+ $item->pointer, @context)
+ if $item->interpreter ne $expected
+ && !$item->calls_env
+ && $expected ne '/usr/bin/env perl'
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('incorrect-path-for-interpreter',
+ $item->pointer, @context)
+ if $item->interpreter ne $expected
+ && !$item->calls_env
+ && $expected eq '/usr/bin/env perl'
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-incorrect-path-for-interpreter',
+ $item->pointer, @context)
+ if $item->interpreter ne $expected
+ && !$item->calls_env
+ && $expected eq '/usr/bin/env perl'
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ } elsif ($item->interpreter =~ m{^/usr/local/}) {
+
+ $self->pointed_hint('interpreter-in-usr-local', $item->pointer,
+ $item->interpreter)
+ if $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-interpreter-in-usr-local',
+ $item->pointer,$item->interpreter)
+ if $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ } elsif ($item->interpreter eq '/bin/env') {
+
+ $self->pointed_hint('script-uses-bin-env', $item->pointer,
+ $item->interpreter)
+ if $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-script-uses-bin-env', $item->pointer,
+ $item->interpreter)
+ if $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ } elsif ($item->interpreter eq 'nodejs') {
+
+ $self->pointed_hint('script-uses-deprecated-nodejs-location',
+ $item->pointer,$item->interpreter)
+ if $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-script-uses-deprecated-nodejs-location',
+ $item->pointer,$item->interpreter)
+ if $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ # Check whether we have correct dependendies on nodejs regardless.
+ $interpreter_data = $self->INTERPRETERS->{'node'};
+
+ } elsif ($basename =~ /^php/) {
+
+ $self->pointed_hint('php-script-with-unusual-interpreter',
+ $item->pointer,$item->interpreter)
+ if $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-php-script-with-unusual-interpreter',
+ $item->pointer, $item->interpreter)
+ if $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+
+ # This allows us to still perform the dependencies checks
+ # below even when an unusual interpreter has been found.
+ $interpreter_data = $self->INTERPRETERS->{'php'};
+
+ } else {
+ my @private_interpreters;
+
+ # Check if the package ships the interpreter (and it is
+ # executable).
+ my $name = $item->interpreter;
+ if ($name =~ s{^/}{}) {
+ my $file = $self->processable->installed->lookup($name);
+ push(@private_interpreters, $file)
+ if defined $file;
+
+ } elsif ($item->calls_env) {
+ my @files= map {
+ $self->processable->installed->lookup(
+ $_ . $SLASH . $item->interpreter)
+ }qw{bin usr/bin};
+ push(@private_interpreters, grep { defined } @files);
+ }
+
+ $self->pointed_hint('unusual-interpreter', $item->pointer,
+ $item->interpreter)
+ if (none { $_->is_file && $_->is_executable } @private_interpreters)
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('example-unusual-interpreter', $item->pointer,
+ $item->interpreter)
+ if (none { $_->is_file && $_->is_executable } @private_interpreters)
+ && $item->name =~ m{^usr/share/doc/[^/]+/examples/};
+ }
+
+ # If we found the interpreter and the script is executable,
+ # check dependencies. This should be the last thing we do in
+ # the loop so that we can use next for an early exit and
+ # reduce the nesting.
+ return
+ unless $interpreter_data;
+
+ return
+ unless $item->is_file && $item->is_executable;
+
+ return
+ if $item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/};
+
+ if (!$versioned) {
+ my $depends = $interpreter_data->{prerequisites};
+
+ if ($depends && !$self->all_prerequisites->satisfies($depends)) {
+
+ if ($basename =~ /^php/) {
+
+ $self->pointed_hint('php-script-but-no-php-cli-dep',
+ $item->pointer, $item->interpreter,
+ "(does not satisfy $depends)");
+
+ } elsif ($basename =~ /^(python\d|ruby|[mg]awk)$/) {
+
+ $self->pointed_hint(
+ (
+ "$basename-script-but-no-$basename-dep",
+ $item->pointer,
+ $item->interpreter,
+ "(does not satisfy $depends)"
+ )
+ );
+
+ } elsif ($basename eq 'csh'
+ && $item->name =~ m{^etc/csh/login\.d/}){
+ # Initialization files for csh.
+
+ } elsif ($basename eq 'fish' && $item->name =~ m{^etc/fish\.d/}) {
+ # Initialization files for fish.
+
+ } elsif (
+ $basename eq 'ocamlrun'
+ && $self->all_prerequisites->matches(
+ qr/^ocaml(?:-base)?(?:-nox)?-\d\.[\d.]+/)
+ ) {
+ # ABI-versioned virtual packages for ocaml
+
+ } elsif ($basename eq 'escript'
+ && $self->all_prerequisites->matches(qr/^erlang-abi-[\d+\.]+$/)
+ ) {
+ # ABI-versioned virtual packages for erlang
+
+ } else {
+
+ $self->pointed_hint('missing-dep-for-interpreter',
+ $item->pointer, $item->interpreter,
+ "(does not satisfy $depends)");
+ }
+ }
+
+ } elsif (exists $self->VERSIONED_INTERPRETERS->{$basename}) {
+ my @versions = @{ $interpreter_data->{versions} };
+
+ my @depends;
+ for my $version (@versions) {
+ my $d = $interpreter_data->{template};
+ $d =~ s/\$1/$version/g;
+ push(@depends, $d);
+ }
+
+ unshift(@depends, $interpreter_data->{prerequisites})
+ if length $interpreter_data->{prerequisites};
+
+ my $depends = join(' | ', @depends);
+ unless ($self->all_prerequisites->satisfies($depends)) {
+ if ($basename =~ /^(wish|tclsh)/) {
+
+ my $shell_name = $1;
+
+ $self->pointed_hint(
+ "$shell_name-script-but-no-$shell_name-dep",
+ $item->pointer, $item->interpreter,
+ "(does not satisfy $depends)");
+
+ } else {
+
+ $self->pointed_hint('missing-dep-for-interpreter',
+ $item->pointer, $item->interpreter,
+ "(does not satisfy $depends)");
+ }
+ }
+
+ } else {
+
+ my ($version) = ($basename =~ /$interpreter_data->{regex}/);
+ my $depends = $interpreter_data->{template};
+ $depends =~ s/\$1/$version/g;
+
+ unless ($self->all_prerequisites->satisfies($depends)) {
+ if ($basename =~ /^(python|ruby)/) {
+
+ $self->pointed_hint("$1-script-but-no-$1-dep",
+ $item->pointer, $item->interpreter,
+ "(does not satisfy $depends)");
+
+ } else {
+
+ $self->pointed_hint('missing-dep-for-interpreter',
+ $item->pointer, $item->interpreter,
+ "(does not satisfy $depends)");
+ }
+ }
+ }
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ if ($item->is_elf) {
+
+ $self->pointed_hint('elf-maintainer-script', $item->pointer);
+ return;
+ }
+
+ # keep 'env', if present
+ my $interpreter = $item->hashbang;
+
+ # keep base command without options
+ $interpreter =~ s/^(\S+).*/$1/;
+
+ if ($interpreter eq $EMPTY) {
+
+ $self->pointed_hint('script-without-interpreter', $item->pointer);
+ return;
+ }
+
+ # tag for statistics
+ $self->pointed_hint('maintainer-script-interpreter',
+ $item->pointer, $interpreter);
+
+ $self->pointed_hint('interpreter-not-absolute', $item->pointer,
+ $interpreter)
+ unless $interpreter =~ m{^/};
+
+ my $basename = basename($interpreter);
+
+ if ($interpreter =~ m{^/usr/local/}) {
+ $self->pointed_hint('control-interpreter-in-usr-local',
+ $item->pointer, $interpreter);
+
+ } elsif ($basename eq 'sh' || $basename eq 'bash' || $basename eq 'perl') {
+ my $expected
+ = $self->INTERPRETERS->{$basename}->{folder}. $SLASH. $basename;
+
+ my $tag_name
+ = ($expected eq '/usr/bin/env perl')
+ ?
+ 'incorrect-path-for-interpreter'
+ : 'wrong-path-for-interpreter';
+
+ $self->pointed_hint(
+ $tag_name, $item->pointer, $interpreter,
+ $NOT_EQUAL, $expected
+ )unless $interpreter eq $expected;
+
+ } elsif ($item->name eq 'config') {
+ $self->pointed_hint('forbidden-config-interpreter',
+ $item->pointer, $interpreter);
+
+ } elsif ($item->name eq 'postrm') {
+ $self->pointed_hint('forbidden-postrm-interpreter',
+ $item->pointer, $interpreter);
+
+ } elsif (exists $self->INTERPRETERS->{$basename}) {
+
+ my $interpreter_data = $self->INTERPRETERS->{$basename};
+ my $expected = $interpreter_data->{folder} . $SLASH . $basename;
+
+ my $tag_name
+ = ($expected eq '/usr/bin/env perl')
+ ?
+ 'incorrect-path-for-interpreter'
+ : 'wrong-path-for-interpreter';
+
+ $self->pointed_hint(
+ $tag_name, $item->pointer, $interpreter,
+ $NOT_EQUAL, $expected
+ )unless $interpreter eq $expected;
+
+ $self->pointed_hint('unusual-control-interpreter', $item->pointer,
+ $interpreter);
+
+ # Interpreters used by preinst scripts must be in
+ # Pre-Depends. Interpreters used by postinst or prerm
+ # scripts must be in Depends.
+ if ($interpreter_data->{prerequisites}) {
+
+ my $depends = Lintian::Relation->new->load(
+ $interpreter_data->{prerequisites});
+
+ if ($item->name eq 'preinst') {
+
+ $self->pointed_hint(
+ 'control-interpreter-without-predepends',
+ $item->pointer,
+ $interpreter,
+ '(does not satisfy ' . $depends->to_string . ')'
+ )
+ unless $self->processable->relation('Pre-Depends')
+ ->satisfies($depends);
+
+ } else {
+
+ $self->pointed_hint(
+ 'control-interpreter-without-depends',
+ $item->pointer,
+ $interpreter,
+ '(does not satisfy ' . $depends->to_string . ')'
+ )
+ unless $self->processable->relation('strong')
+ ->satisfies($depends);
+ }
+ }
+
+ } else {
+ $self->pointed_hint('unknown-control-interpreter', $item->pointer,
+ $interpreter);
+
+ # no use doing further checks if it's not a known interpreter
+ return;
+ }
+
+ return
+ unless $item->is_open_ok;
+
+ # now scan the file contents themselves
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $saw_debconf;
+ my $saw_bange;
+ my $saw_sete;
+ my $saw_udevadm_guard;
+
+ my $cat_string = $EMPTY;
+
+ my $previous_line = $EMPTY;
+ my $in_automatic_section = 0;
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ $saw_bange = 1
+ if $position == 1
+ && $item->is_shell_script
+ && $line =~ m{/$basename\s*.*\s-\w*e\w*\b};
+
+ $in_automatic_section = 1
+ if $line =~ /^# Automatically added by \S+\s*$/;
+
+ $in_automatic_section = 0
+ if $line eq '# End automatically added section';
+
+ # skip empty lines
+ next
+ if $line =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $line =~ /^\s*\#/;
+
+ $line = remove_comments($line);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($item->is_shell_script && $line =~ /\\$/) {
+
+ $line =~ s/\\//;
+ chomp $line;
+ $previous_line .= $line;
+
+ next;
+ }
+
+ chomp $line;
+
+ $line = $previous_line . $line;
+ $previous_line = $EMPTY;
+
+ $saw_sete = 1
+ if $item->is_shell_script
+ && $line =~ /${LEADING_REGEX}set\s*(?:\s+-(?:-.*|[^e]+))*\s-\w*e/;
+
+ $saw_udevadm_guard = 1
+ if $line =~ /\b(if|which|command)\s+.*udevadm/g;
+
+ if ($line =~ m{$LEADING_REGEX(?:/bin/)?udevadm\s} && $saw_sete) {
+
+ $self->pointed_hint('udevadm-called-without-guard',$pointer)
+ unless $saw_udevadm_guard
+ || $line =~ m{\|\|}
+ || $self->strong_prerequisites->satisfies('udev:any');
+ }
+
+ if ($item->is_shell_script) {
+
+ $cat_string = $EMPTY
+ if $cat_string ne $EMPTY
+ && $line =~ /^\Q$cat_string\E$/;
+
+ my $within_another_shell = 0;
+
+ $within_another_shell = 1
+ if $item->interpreter !~ m{(?:^|/)sh$}
+ && $item->interpreter_with_options =~ /\S+\s+-c/;
+
+ if (!$cat_string) {
+
+ $self->generic_check_bad_command($item, $line,
+ $position, 0,$in_automatic_section);
+
+ $saw_debconf = 1
+ if $line =~ m{/usr/share/debconf/confmodule};
+
+ $self->pointed_hint('read-in-maintainer-script',$pointer)
+ if $line =~ /^\s*read(?:\s|\z)/ && !$saw_debconf;
+
+ $self->pointed_hint('multi-arch-same-package-calls-pycompile',
+ $pointer)
+ if $line =~ /^\s*py3?compile(?:\s|\z)/
+ &&$self->processable->fields->value('Multi-Arch') eq 'same';
+
+ $self->pointed_hint('maintainer-script-modifies-inetd-conf',
+ $pointer)
+ if $line =~ m{>\s*/etc/inetd\.conf(?:\s|\Z)}
+ && !$self->processable->relation('Provides')
+ ->satisfies('inet-superserver:any');
+
+ $self->pointed_hint('maintainer-script-modifies-inetd-conf',
+ $pointer)
+ if $line=~ m{^\s*(?:cp|mv)\s+(?:.*\s)?/etc/inetd\.conf\s*$}
+ && !$self->processable->relation('Provides')
+ ->satisfies('inet-superserver:any');
+
+ # Check for running commands with a leading path.
+ #
+ # Unfortunately, our $LEADING_REGEX string doesn't work
+ # well for this in the presence of commands that
+ # contain backquoted expressions because it can't
+ # tell the difference between the initial backtick
+ # and the closing backtick. We therefore first
+ # extract all backquoted expressions and check
+ # them separately, and then remove them from a
+ # copy of a string and then check it for bashisms.
+ while ($line =~ /\`([^\`]+)\`/g) {
+
+ my $mangled = $1;
+
+ if (
+ $mangled =~ m{ $LEADING_REGEX
+ (/(?:usr/)?s?bin/[\w.+-]+)
+ (?:\s|;|\Z)}xsm
+ ) {
+ my $command = $1;
+
+ $self->pointed_hint(
+ 'command-with-path-in-maintainer-script',
+ $pointer, $command,'(in backticks)')
+ unless $in_automatic_section;
+ }
+ }
+
+ # check for test syntax
+ if(
+ $line =~ m{\[\s+
+ (?:!\s+)? -x \s+
+ (/(?:usr/)?s?bin/[\w.+-]+)
+ \s+ \]}xsm
+ ){
+ my $command = $1;
+
+ $self->pointed_hint(
+ 'command-with-path-in-maintainer-script',
+ $pointer, $command,'(in test syntax)')
+ unless $in_automatic_section;
+ }
+
+ my $mangled = $line;
+ $mangled =~ s/\`[^\`]+\`//g;
+
+ if ($mangled
+ =~ m{$LEADING_REGEX(/(?:usr/)?s?bin/[\w.+-]+)(?:\s|;|$)}){
+ my $command = $1;
+
+ $self->pointed_hint(
+ 'command-with-path-in-maintainer-script',
+ $pointer, $command, '(plain script)')
+ unless $in_automatic_section;
+ }
+ }
+ }
+
+ for my $pattern (keys %prerequisite_by_command_pattern) {
+
+ next
+ unless $line =~ /($pattern)/;
+
+ my $command = $1;
+
+ next
+ if $line =~ /-x\s+\S*$pattern/
+ || $line =~ /(?:which|type)\s+$pattern/
+ || $line =~ /command\s+.*?$pattern/
+ || $line =~ m{ [|][|] \s* true \b }x;
+
+ my $requirement = $prerequisite_by_command_pattern{$pattern};
+
+ my $first_alternative = $requirement;
+ $first_alternative =~ s/[ \(].*//;
+
+ $self->pointed_hint(
+ "maintainer-script-needs-depends-on-$first_alternative",
+ $pointer, $command,"(does not satisfy $requirement)")
+ unless $self->processable->relation('strong')
+ ->satisfies($requirement)
+ || $self->processable->name eq $first_alternative
+ || $item->name eq 'postrm';
+ }
+
+ $self->generic_check_bad_command($item, $line, $position, 1,
+ $in_automatic_section);
+
+ if ($line =~ m{$LEADING_REGEX(?:/usr/sbin/)?update-inetd\s}) {
+
+ $self->pointed_hint(
+ 'maintainer-script-has-invalid-update-inetd-options',
+ $pointer, '(--pattern with --add)')
+ if $line =~ /--pattern/
+ && $line =~ /--add/;
+
+ $self->pointed_hint(
+ 'maintainer-script-has-invalid-update-inetd-options',
+ $pointer, '(--group without --add)')
+ if $line =~ /--group/
+ && $line !~ /--add/;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ $self->pointed_hint('maintainer-script-without-set-e', $item->pointer)
+ if $item->is_shell_script && !$saw_sete && $saw_bange;
+
+ $self->pointed_hint('maintainer-script-ignores-errors', $item->pointer)
+ if $item->is_shell_script && !$saw_sete && !$saw_bange;
+
+ return;
+}
+
+sub generic_check_bad_command {
+ my ($self, $script, $line, $position, $find_in_cat_string,
+ $in_automatic_section)
+ = @_;
+
+ for my $tag_name (keys %{$self->BAD_MAINTAINER_COMMANDS}) {
+
+ my $command_data= $self->BAD_MAINTAINER_COMMANDS->{$tag_name};
+
+ next
+ if $in_automatic_section
+ && $command_data->{ignore_automatic_sections};
+
+ next
+ unless $script->name =~ $command_data->{script_include_regex};
+
+ next
+ unless $find_in_cat_string == $command_data->{in_cat_string};
+
+ if ($line =~ m{ ( $command_data->{command_pattern} ) }x) {
+
+ my $bad_command = $1 // $EMPTY;
+
+ # trim both ends
+ $bad_command =~ s/^\s+|\s+$//g;
+
+ my $pointer = $script->pointer($position);
+
+ $self->pointed_hint($tag_name, $pointer,
+ $DOUBLE_QUOTE . $bad_command . $DOUBLE_QUOTE)
+ unless $self->processable->name
+ =~ $command_data->{package_exclude_regex};
+ }
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Shell/Bash/Completion.pm b/lib/Lintian/Check/Shell/Bash/Completion.pm
new file mode 100644
index 0000000..4b0584e
--- /dev/null
+++ b/lib/Lintian/Check/Shell/Bash/Completion.pm
@@ -0,0 +1,54 @@
+# shell/bash/completion -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Shell::Bash::Completion;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^ usr/share/bash-completion/completions/ }x;
+
+ $self->pointed_hint('bash-completion-with-hashbang',
+ $item->pointer(1), $item->hashbang)
+ if length $item->hashbang;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Shell/Csh.pm b/lib/Lintian/Check/Shell/Csh.pm
new file mode 100644
index 0000000..f84d374
--- /dev/null
+++ b/lib/Lintian/Check/Shell/Csh.pm
@@ -0,0 +1,89 @@
+# shell/csh -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Shell::Csh;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use File::Basename;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ # Consider /usr/src/ scripts as "documentation"
+ # - packages containing /usr/src/ tend to be "-source" .debs
+ # and usually come with overrides
+ # no checks necessary at all for scripts in /usr/share/doc/
+ # unless they are examples
+ return
+ if ($item->name =~ m{^usr/share/doc/} || $item->name =~ m{^usr/src/})
+ && $item->name !~ m{^usr/share/doc/[^/]+/examples/};
+
+ $self->pointed_hint('csh-considered-harmful', $item->pointer(1),
+ $item->interpreter)
+ if $self->is_csh_script($item)
+ && $item->name !~ m{^ etc/csh/login[.]d/ }x;
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ # perhaps we should warn about *csh even if they're somehow screwed,
+ # but that's not really important...
+ $self->pointed_hint('csh-considered-harmful', $item->pointer(1),
+ $item->interpreter)
+ if $self->is_csh_script($item);
+
+ return;
+}
+
+sub is_csh_script {
+ my ($self, $item) = @_;
+
+ return 0
+ unless length $item->interpreter;
+
+ my $basename = basename($item->interpreter);
+
+ return 1
+ if $basename eq 'csh' || $basename eq 'tcsh';
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Shell/NonPosix/BashCentric.pm b/lib/Lintian/Check/Shell/NonPosix/BashCentric.pm
new file mode 100644
index 0000000..024ea6a
--- /dev/null
+++ b/lib/Lintian/Check/Shell/NonPosix/BashCentric.pm
@@ -0,0 +1,348 @@
+# shell/non-posix/bash-centric -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+# Copyright (C) 2021 Rafael Laboissiere
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+# bashism sounded too much like fascism
+package Lintian::Check::Shell::NonPosix::BashCentric;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::SomeUtils qw(uniq);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+# When detecting commands inside shell scripts, use this regex to match the
+# beginning of the command rather than checking whether the command is at the
+# beginning of a line.
+const my $LEADING_PATTERN=>
+'(?:(?:^|[`&;(|{])\s*|(?:if|then|do|while|!)\s+|env(?:\s+[[:alnum:]_]+=(?:\S+|\"[^"]*\"|\'[^\']*\'))*\s+)';
+const my $LEADING_REGEX => qr/$LEADING_PATTERN/;
+
+my @bashism_single_quote_regexes = (
+ $LEADING_REGEX
+ . qr{echo\s+(?:-[^e\s]+\s+)?\'[^\']*(\\[abcEfnrtv0])+.*?[\']},
+ # unsafe echo with backslashes
+ $LEADING_REGEX . qr{source\s+[\"\']?(?:\.\/|[\/\$\w~.-])\S*},
+ # should be '.', not 'source'
+);
+
+my @bashism_string_regexes = (
+ qr/\$\[\w+\]/, # arith not allowed
+ qr/\$\{\w+\:\d+(?::\d+)?\}/, # ${foo:3[:1]}
+ qr/\$\{\w+(\/.+?){1,2}\}/, # ${parm/?/pat[/str]}
+ qr/\$\{\#?\w+\[[0-9\*\@]+\]\}/,# bash arrays, ${name[0|*|@]}
+ qr/\$\{!\w+[\@*]\}/, # ${!prefix[*|@]}
+ qr/\$\{!\w+\}/, # ${!name}
+ qr/(\$\(|\`)\s*\<\s*\S+\s*([\)\`])/, # $(\< foo) should be $(cat foo)
+ qr/\$\{?RANDOM\}?\b/, # $RANDOM
+ qr/\$\{?(OS|MACH)TYPE\}?\b/, # $(OS|MACH)TYPE
+ qr/\$\{?HOST(TYPE|NAME)\}?\b/, # $HOST(TYPE|NAME)
+ qr/\$\{?DIRSTACK\}?\b/, # $DIRSTACK
+ qr/\$\{?EUID\}?\b/, # $EUID should be "id -u"
+ qr/\$\{?UID\}?\b/, # $UID should be "id -ru"
+ qr/\$\{?SECONDS\}?\b/, # $SECONDS
+ qr/\$\{?BASH_[A-Z]+\}?\b/, # $BASH_SOMETHING
+ qr/\$\{?SHELLOPTS\}?\b/, # $SHELLOPTS
+ qr/\$\{?PIPESTATUS\}?\b/, # $PIPESTATUS
+ qr/\$\{?SHLVL\}?\b/, # $SHLVL
+ qr/<<</, # <<< here string
+ $LEADING_REGEX
+ . qr/echo\s+(?:-[^e\s]+\s+)?\"[^\"]*(\\[abcEfnrtv0])+.*?[\"]/,
+ # unsafe echo with backslashes
+);
+
+my @bashism_regexes = (
+ qr/(?:^|\s+)function \w+(\s|\(|\Z)/, # function is useless
+ qr/(test|-o|-a)\s*[^\s]+\s+==\s/, # should be 'b = a'
+ qr/\[\s+[^\]]+\s+==\s/, # should be 'b = a'
+ qr/\s(\|\&)/, # pipelining is not POSIX
+ qr/[^\\\$]\{(?:[^\s\\\}]*?,)+[^\\\}\s]*\}/, # brace expansion
+ qr/(?:^|\s+)\w+\[\d+\]=/, # bash arrays, H[0]
+ $LEADING_REGEX . qr/read\s+(?:-[a-qs-zA-Z\d-]+)/,
+ # read with option other than -r
+ $LEADING_REGEX . qr/read\s*(?:-\w+\s*)*(?:\".*?\"|[\'].*?[\'])?\s*(?:;|$)/,
+ # read without variable
+ qr/\&>/, # cshism
+ qr/(<\&|>\&)\s*((-|\d+)[^\s;|)`&\\\\]|[^-\d\s]+)/, # should be >word 2>&1
+ qr/\[\[(?!:)/, # alternative test command
+ $LEADING_REGEX . qr/select\s+\w+/, # 'select' is not POSIX
+ $LEADING_REGEX . qr/echo\s+(-n\s+)?-n?en?/, # echo -e
+ $LEADING_REGEX . qr/exec\s+-[acl]/, # exec -c/-l/-a name
+ qr/(?:^|\s+)let\s/, # let ...
+ qr/(?<![\$\(])\(\(.*\)\)/, # '((' should be '$(('
+ qr/\$\[[^][]+\]/, # '$[' should be '$(('
+ qr/(\[|test)\s+-a/, # test with unary -a (should be -e)
+ qr{/dev/(tcp|udp)}, # /dev/(tcp|udp)
+ $LEADING_REGEX . qr/\w+\+=/, # should be "VAR="${VAR}foo"
+ $LEADING_REGEX . qr/suspend\s/,
+ $LEADING_REGEX . qr/caller\s/,
+ $LEADING_REGEX . qr/complete\s/,
+ $LEADING_REGEX . qr/compgen\s/,
+ $LEADING_REGEX . qr/declare\s/,
+ $LEADING_REGEX . qr/typeset\s/,
+ $LEADING_REGEX . qr/disown\s/,
+ $LEADING_REGEX . qr/builtin\s/,
+ $LEADING_REGEX . qr/set\s+-[BHT]+/, # set -[BHT]
+ $LEADING_REGEX . qr/alias\s+-p/, # alias -p
+ $LEADING_REGEX . qr/unalias\s+-a/, # unalias -a
+ $LEADING_REGEX . qr/local\s+-[a-zA-Z]+/, # local -opt
+ qr/(?:^|\s+)\s*\(?\w*[^\(\w\s]+\S*?\s*\(\)\s*([\{|\(]|\Z)/,
+ # function names should only contain [a-z0-9_]
+ $LEADING_REGEX . qr/(push|pop)d(\s|\Z)/, # (push|pod)d
+ $LEADING_REGEX . qr/export\s+-[^p]/, # export only takes -p as an option
+ $LEADING_REGEX . qr/ulimit(\s|\Z)/,
+ $LEADING_REGEX . qr/shopt(\s|\Z)/,
+ $LEADING_REGEX . qr/time\s/,
+ $LEADING_REGEX . qr/dirs(\s|\Z)/,
+ qr/(?:^|\s+)[<>]\(.*?\)/, # <() process substitution
+ qr/(?:^|\s+)readonly\s+-[af]/, # readonly -[af]
+ $LEADING_REGEX . qr/(sh|\$\{?SHELL\}?) -[rD]/, # sh -[rD]
+ $LEADING_REGEX . qr/(sh|\$\{?SHELL\}?) --\w+/, # sh --long-option
+ $LEADING_REGEX . qr/(sh|\$\{?SHELL\}?) [-+]O/, # sh [-+]O
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless length $item->interpreter;
+
+ my $basename = basename($item->interpreter);
+
+ return
+ unless $basename eq 'sh';
+
+ $self->check_bash_centric($item, 'bash-term-in-posix-shell');
+
+ return;
+}
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless length $item->interpreter;
+
+ my $basename = basename($item->interpreter);
+
+ return
+ unless $basename eq 'sh';
+
+ $self->check_bash_centric($item, 'possible-bashism-in-maintainer-script');
+
+ return;
+}
+
+sub check_bash_centric {
+ my ($self, $item, $tag_name) = @_;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ # see Bug#999756 and tclsh(1)
+ last
+ if $line =~ m{^ exec \s }x;
+
+ my $pointer = $item->pointer($position);
+
+ my @matches = uniq +$self->check_line($line);
+
+ for my $match (@matches) {
+
+ my $printable = "'$match'";
+ $printable = '{hex:' . sprintf('%vX', $match) . '}'
+ if $match =~ /\P{XPosixPrint}/;
+
+ $self->pointed_hint($tag_name, $pointer, $printable);
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return;
+}
+
+sub check_line {
+ my ($self, $line) = @_;
+
+ my @matches;
+
+ # since this test is ugly, I have to do it by itself
+ # detect source (.) trying to pass args to the command it runs
+ # The first expression weeds out '. "foo bar"'
+ if (
+ $line !~ m{\A \s*\.\s+
+ (?:\"[^\"]+\"|\'[^\']+\')\s*
+ (?:[\&\|<;]|\d?>|\Z)}xsm
+ && $line =~ /^\s*(\.\s+[^\s;\`:]+\s+([^\s;]+))/
+ ) {
+
+ my ($dot_command, $extra) = ($1, $2);
+
+ push(@matches, $dot_command)
+ if length $dot_command
+ && $extra !~ m{^ & | [|] | < | \d? > }x;
+ }
+
+ my $modified = $line;
+
+ for my $regex (@bashism_single_quote_regexes) {
+ if ($modified =~ $regex) {
+
+ # on unmodified line
+ my ($match) = ($line =~ /($regex)/);
+
+ push(@matches, $match)
+ if length $match;
+ }
+ }
+
+ # Ignore anything inside single quotes; it could be an
+ # argument to grep or the like.
+
+ # Remove "quoted quotes". They're likely to be
+ # inside another pair of quotes; we're not
+ # interested in them for their own sake and
+ # removing them makes finding the limits of
+ # the outer pair far easier.
+ $modified =~ s/(^|[^\\\'\"])\"\'\"/$1/g;
+ $modified =~ s/(^|[^\\\'\"])\'\"\'/$1/g;
+
+ $modified =~ s/(^|[^\\\"](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+
+ for my $regex (@bashism_string_regexes) {
+ if ($modified =~ $regex) {
+
+ # on unmodified line
+ my ($match) = ($line =~ /($regex)/);
+
+ $match //= $EMPTY;
+
+ push(@matches, $match)
+ if length $match;
+ }
+ }
+
+ $modified =~ s/(^|[^\\\'](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ for my $regex (@bashism_regexes) {
+ if ($modified =~ $regex) {
+
+ # on unmodified line
+ my ($match) = ($line =~ /($regex)/);
+
+ $match //= $EMPTY;
+
+ push(@matches, $match)
+ if length $match;
+ }
+ }
+
+ # trim both ends of each element
+ s/^\s+|\s+$//g for @matches;
+
+ my @meaningful = grep { length } @matches;
+
+ return @meaningful;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Substvars/Libc.pm b/lib/Lintian/Check/Substvars/Libc.pm
new file mode 100644
index 0000000..db97ee5
--- /dev/null
+++ b/lib/Lintian/Check/Substvars/Libc.pm
@@ -0,0 +1,86 @@
+# substvars/libc -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Substvars::Libc;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# The list of libc packages, used for checking for a hard-coded dependency
+# rather than using ${shlibs:Depends}.
+const my @LIBCS => qw(libc6:any libc6.1:any libc0.1:any libc0.3:any);
+
+my $LIBC_RELATION = Lintian::Relation->new->load(join(' | ', @LIBCS));
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ my @prerequisite_fields = qw(Pre-Depends Depends Recommends Suggests);
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ for my $field (@prerequisite_fields) {
+
+ next
+ unless $control->installable_fields($installable)
+ ->declares($field);
+
+ my $relation
+ = $self->processable->binary_relation($installable,$field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint(
+ 'package-depends-on-hardcoded-libc',
+ $pointer,"(in section for $installable)",
+ $field, $relation->to_string
+ )
+ if $relation->satisfies($LIBC_RELATION)
+ && $self->processable->name !~ /^e?glibc$/;
+ }
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Substvars/Misc/PreDepends.pm b/lib/Lintian/Check/Substvars/Misc/PreDepends.pm
new file mode 100644
index 0000000..6172aca
--- /dev/null
+++ b/lib/Lintian/Check/Substvars/Misc/PreDepends.pm
@@ -0,0 +1,64 @@
+# substvars/misc/pre-depends -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Substvars::Misc::PreDepends;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $control = $self->processable->debian_control;
+
+ for my $installable ($control->installables) {
+ my $installable_fields = $control->installable_fields($installable);
+
+ my $field = 'Depends';
+
+ my $depends= $control->installable_fields($installable)->value($field);
+
+ my $control_item= $self->processable->debian_control->item;
+ my $position = $installable_fields->position($field);
+ my $pointer = $control_item->pointer($position);
+
+ $self->pointed_hint('depends-on-misc-pre-depends', $pointer,$depends,
+ "(in section for $installable)")
+ if $depends =~ m/\$\{misc:Pre-Depends\}/;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Systemd.pm b/lib/Lintian/Check/Systemd.pm
new file mode 100644
index 0000000..39487e0
--- /dev/null
+++ b/lib/Lintian/Check/Systemd.pm
@@ -0,0 +1,530 @@
+# systemd -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2013 Michael Stapelberg
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# based on the apache2 checks file by:
+# Copyright (C) 2012 Arno Toell
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Systemd;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Data::Validate::URI qw(is_uri);
+use List::Compare;
+use List::SomeUtils qw(any none);
+use Text::ParseWords qw(shellwords);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+# "Usual" targets for WantedBy
+const my @WANTEDBY_WHITELIST => qw{
+ default.target
+ graphical.target
+ multi-user.target
+ network-online.target
+ sleep.target
+ sysinit.target
+};
+
+# Known hardening flags in [Service] section
+const my @HARDENING_FLAGS => qw{
+ CapabilityBoundingSet
+ DeviceAllow
+ DynamicUser
+ IPAddressDeny
+ InaccessiblePaths
+ KeyringMode
+ LimitNOFILE
+ LockPersonality
+ MemoryDenyWriteExecute
+ MountFlags
+ NoNewPrivileges
+ PrivateDevices
+ PrivateMounts
+ PrivateNetwork
+ PrivateTmp
+ PrivateUsers
+ ProtectControlGroups
+ ProtectHome
+ ProtectHostname
+ ProtectKernelLogs
+ ProtectKernelModules
+ ProtectKernelTunables
+ ProtectSystem
+ ReadOnlyPaths
+ RemoveIPC
+ RestrictAddressFamilies
+ RestrictNamespaces
+ RestrictRealtime
+ RestrictSUIDSGID
+ SystemCallArchitectures
+ SystemCallFilter
+ UMask
+};
+
+# init scripts that do not need a service file
+has PROVIDED_BY_SYSTEMD => (
+ is => 'rw',
+ lazy => 1,
+ default =>sub {
+ my ($self) = @_;
+
+ return $self->data->load('systemd/init-whitelist');
+ }
+);
+
+# array of names provided by the service files.
+# This includes Alias= directives, so after parsing
+# NetworkManager.service, it will contain NetworkManager and
+# network-manager.
+has service_names => (is => 'rw', default => sub { [] });
+
+has timer_files => (is => 'rw', default => sub { [] });
+
+has init_files_by_service_name => (is => 'rw', default => sub { {} });
+has cron_scripts => (is => 'rw', default => sub { [] });
+
+has is_rcs_script_by_name => (is => 'rw', default => sub { {} });
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->name =~ m{/systemd/system/.*\.service$}) {
+
+ $self->check_systemd_service_file($item);
+
+ my $service_name = $item->basename;
+ $service_name =~ s/@?\.service$//;
+
+ push(@{$self->service_names}, $service_name);
+
+ my @aliases
+ = $self->extract_service_file_values($item, 'Install', 'Alias');
+
+ for my $alias (@aliases) {
+
+ $self->pointed_hint('systemd-service-alias-without-extension',
+ $item->pointer)
+ if $alias !~ m/\.service$/;
+
+ # maybe issue a tag for duplicates?
+
+ $alias =~ s{ [.]service $}{}x;
+ push(@{$self->service_names}, $alias);
+ }
+ }
+
+ push(@{$self->timer_files}, $item)
+ if $item->name =~ m{^(?:usr/)?lib/systemd/system/[^\/]+\.timer$};
+
+ push(@{$self->cron_scripts}, $item)
+ if $item->dirname =~ m{^ etc/cron[.][^\/]+ / $}x;
+
+ if (
+ $item->dirname eq 'etc/init.d/'
+ && !$item->is_dir
+ && (none { $item->basename eq $_} qw{README skeleton rc rcS})
+ && $self->processable->name ne 'initscripts'
+ && $item->link ne 'lib/init/upstart-job'
+ ) {
+
+ unless ($item->is_file) {
+
+ $self->pointed_hint('init-script-is-not-a-file', $item->pointer);
+ return;
+ }
+
+ # sysv generator drops the .sh suffix
+ my $service_name = $item->basename;
+ $service_name =~ s{ [.]sh $}{}x;
+
+ $self->init_files_by_service_name->{$service_name} //= [];
+ push(@{$self->init_files_by_service_name->{$service_name}}, $item);
+
+ $self->is_rcs_script_by_name->{$item->name}
+ = $self->check_init_script($item);
+ }
+
+ if ($item->name =~ m{ /systemd/system/ .*[.]socket $}x) {
+
+ my @values
+ = $self->extract_service_file_values($item,'Socket','ListenStream');
+
+ $self->pointed_hint('systemd-service-file-refers-to-var-run',
+ $item->pointer, 'ListenStream', $_)
+ for grep { m{^/var/run/} } @values;
+ }
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $lc = List::Compare->new([keys %{$self->init_files_by_service_name}],
+ $self->service_names);
+
+ my @missing_service_names = $lc->get_Lonly;
+
+ for my $service_name (@missing_service_names) {
+
+ next
+ if $self->PROVIDED_BY_SYSTEMD->recognizes($service_name);
+
+ my @init_files
+ = @{$self->init_files_by_service_name->{$service_name} // []};
+
+ for my $init_file (@init_files) {
+
+ # rcS scripts are particularly bad; always tag
+ $self->pointed_hint(
+ 'missing-systemd-service-for-init.d-rcS-script',
+ $init_file->pointer, $service_name)
+ if $self->is_rcs_script_by_name->{$init_file->name};
+
+ $self->pointed_hint('omitted-systemd-service-for-init.d-script',
+ $init_file->pointer, $service_name)
+ if @{$self->service_names}
+ && !$self->is_rcs_script_by_name->{$init_file->name};
+
+ $self->pointed_hint('missing-systemd-service-for-init.d-script',
+ $init_file->pointer, $service_name)
+ if !@{$self->service_names}
+ && !$self->is_rcs_script_by_name->{$init_file->name};
+ }
+ }
+
+ if (!@{$self->timer_files}) {
+
+ $self->pointed_hint('missing-systemd-timer-for-cron-script',
+ $_->pointer)
+ for @{$self->cron_scripts};
+ }
+
+ return;
+}
+
+# Verify that each init script includes /lib/lsb/init-functions,
+# because that is where the systemd diversion happens.
+sub check_init_script {
+ my ($self, $item) = @_;
+
+ my $lsb_source_seen;
+ my $is_rcs_script = 0;
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ # trim left
+ $line =~ s/^\s+//;
+
+ $lsb_source_seen = 1
+ if $position == 1
+ && $line
+ =~ m{\A [#]! \s* (?:/usr/bin/env)? \s* /lib/init/init-d-script}xsm;
+
+ $is_rcs_script = 1
+ if $line =~ m{#.*Default-Start:.*S};
+
+ next
+ if $line =~ /^#/;
+
+ $lsb_source_seen = 1
+ if $line
+ =~ m{(?:\.|source)\s+/lib/(?:lsb/init-functions|init/init-d-script)};
+
+ } continue {
+ ++$position;
+ }
+
+ $self->pointed_hint('init.d-script-does-not-source-init-functions',
+ $item->pointer)
+ unless $lsb_source_seen;
+
+ return $is_rcs_script;
+}
+
+sub check_systemd_service_file {
+ my ($self, $item) = @_;
+
+ # ambivalent about /lib or /usr/lib
+ $self->pointed_hint('systemd-service-in-odd-location', $item->pointer)
+ if $item =~ m{^etc/systemd/system/};
+
+ unless ($item->is_open_ok
+ || ($item->is_symlink && $item->link eq '/dev/null')) {
+
+ $self->pointed_hint('service-file-is-not-a-file', $item->pointer);
+ return 0;
+ }
+
+ my @values = $self->extract_service_file_values($item, 'Unit', 'After');
+ my @obsolete = grep { /^(?:syslog|dbus)\.target$/ } @values;
+
+ $self->pointed_hint('systemd-service-file-refers-to-obsolete-target',
+ $item->pointer, $_)
+ for @obsolete;
+
+ $self->pointed_hint('systemd-service-file-refers-to-obsolete-bindto',
+ $item->pointer)
+ if $self->extract_service_file_values($item, 'Unit', 'BindTo');
+
+ for my $key (
+ qw(ExecStart ExecStartPre ExecStartPost ExecReload ExecStop ExecStopPost)
+ ) {
+ $self->pointed_hint('systemd-service-file-wraps-init-script',
+ $item->pointer, $key)
+ if any { m{^/etc/init\.d/} }
+ $self->extract_service_file_values($item, 'Service', $key);
+ }
+
+ unless ($item->link eq '/dev/null') {
+
+ my @wanted_by
+ = $self->extract_service_file_values($item, 'Install', 'WantedBy');
+ my $is_oneshot = any { $_ eq 'oneshot' }
+ $self->extract_service_file_values($item, 'Service', 'Type');
+
+ # We are a "standalone" service file if we have no .path or .timer
+ # equivalent.
+ my $is_standalone = 1;
+ if ($item =~ m{^(usr/)?lib/systemd/system/([^/]*?)@?\.service$}) {
+
+ my ($usr, $service) = ($1 // $EMPTY, $2);
+
+ $is_standalone = 0
+ if $self->processable->installed->resolve_path(
+ "${usr}lib/systemd/system/${service}.path")
+ || $self->processable->installed->resolve_path(
+ "${usr}lib/systemd/system/${service}.timer");
+ }
+
+ for my $target (@wanted_by) {
+
+ $self->pointed_hint(
+ 'systemd-service-file-refers-to-unusual-wantedby-target',
+ $item->pointer, $target)
+ unless (any { $target eq $_ } @WANTEDBY_WHITELIST)
+ || $self->processable->name eq 'systemd';
+ }
+
+ my @documentation
+ = $self->extract_service_file_values($item, 'Unit','Documentation');
+
+ $self->pointed_hint('systemd-service-file-missing-documentation-key',
+ $item->pointer)
+ unless @documentation;
+
+ for my $documentation (@documentation) {
+
+ my @uris = split(m{\s+}, $documentation);
+
+ my @invalid = grep { !is_uri($_) } @uris;
+
+ $self->pointed_hint('invalid-systemd-documentation',
+ $item->pointer, $_)
+ for @invalid;
+ }
+
+ my @kill_modes
+ = $self->extract_service_file_values($item, 'Service','KillMode');
+
+ for my $kill_mode (@kill_modes) {
+
+ # trim both ends
+ $kill_mode =~ s/^\s+|\s+$//g;
+
+ $self->pointed_hint('kill-mode-none',$item->pointer, $_)
+ if $kill_mode eq 'none';
+ }
+
+ if ( !@wanted_by
+ && !$is_oneshot
+ && $is_standalone
+ && $item =~ m{^(?:usr/)?lib/systemd/[^\/]+/[^\/]+\.service$}
+ && $item !~ m{@\.service$}) {
+
+ $self->pointed_hint('systemd-service-file-missing-install-key',
+ $item->pointer)
+ unless $self->extract_service_file_values($item, 'Install',
+ 'RequiredBy')
+ || $self->extract_service_file_values($item, 'Install', 'Also');
+ }
+
+ my @pidfile
+ = $self->extract_service_file_values($item,'Service','PIDFile');
+ for my $x (@pidfile) {
+ $self->pointed_hint('systemd-service-file-refers-to-var-run',
+ $item->pointer, 'PIDFile', $x)
+ if $x =~ m{^/var/run/};
+ }
+
+ my $seen_hardening
+ = any { $self->extract_service_file_values($item, 'Service', $_) }
+ @HARDENING_FLAGS;
+
+ $self->pointed_hint('systemd-service-file-missing-hardening-features',
+ $item->pointer)
+ unless $seen_hardening
+ || $is_oneshot
+ || any { 'sleep.target' eq $_ } @wanted_by;
+
+ if (
+ $self->extract_service_file_values(
+ $item, 'Unit', 'DefaultDependencies', 1
+ )
+ ) {
+ my @before
+ = $self->extract_service_file_values($item, 'Unit','Before');
+ my @conflicts
+ = $self->extract_service_file_values($item, 'Unit','Conflicts');
+
+ $self->pointed_hint('systemd-service-file-shutdown-problems',
+ $item->pointer)
+ if (none { $_ eq 'shutdown.target' } @before)
+ && (any { $_ eq 'shutdown.target' } @conflicts);
+ }
+
+ my %bad_users = (
+ 'User' => 'nobody',
+ 'Group' => 'nogroup',
+ );
+
+ for my $key (keys %bad_users) {
+
+ my $value = $bad_users{$key};
+
+ $self->pointed_hint('systemd-service-file-uses-nobody-or-nogroup',
+ $item->pointer, "$key=$value")
+ if any { $_ eq $value }
+ $self->extract_service_file_values($item, 'Service',$key);
+ }
+
+ for my $key (qw(StandardError StandardOutput)) {
+ for my $value (qw(syslog syslog-console)) {
+
+ $self->pointed_hint(
+ 'systemd-service-file-uses-deprecated-syslog-facility',
+ $item->pointer, "$key=$value")
+ if any { $_ eq $value }
+ $self->extract_service_file_values($item, 'Service',$key);
+ }
+ }
+ }
+
+ return 1;
+}
+
+sub service_file_lines {
+ my ($item) = @_;
+
+ my @output;
+
+ return @output
+ if $item->is_symlink and $item->link eq '/dev/null';
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+ my $continuation = $EMPTY;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ $line = $continuation . $line;
+ $continuation = $EMPTY;
+
+ if ($line =~ s/\\$/ /) {
+ $continuation = $line;
+ next;
+ }
+
+ # trim right
+ $line =~ s/\s+$//;
+
+ next
+ unless length $line;
+
+ next
+ if $line =~ /^[#;\n]/;
+
+ push(@output, $line);
+ }
+
+ return @output;
+}
+
+# Extracts the values of a specific Key from a .service file
+sub extract_service_file_values {
+ my ($self, $item, $extract_section, $extract_key) = @_;
+
+ return ()
+ unless length $extract_section && length $extract_key;
+
+ my @values;
+ my $section;
+
+ my @lines = service_file_lines($item);
+ for my $line (@lines) {
+ # section header
+ if ($line =~ /^\[([^\]]+)\]$/) {
+ $section = $1;
+ next;
+ }
+
+ if (!defined($section)) {
+ # Assignment outside of section. Ignoring.
+ next;
+ }
+
+ my ($key, $value) = ($line =~ m{^(.*)\s*=\s*(.*)$});
+ if ( defined($key)
+ && $section eq $extract_section
+ && $key eq $extract_key) {
+
+ if (length $value) {
+ push(@values, shellwords($value));
+
+ } else {
+ # Empty assignment resets the list
+ @values = ();
+ }
+ }
+ }
+
+ return @values;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Systemd/Native/Prerequisites.pm b/lib/Lintian/Check/Systemd/Native/Prerequisites.pm
new file mode 100644
index 0000000..5a2480f
--- /dev/null
+++ b/lib/Lintian/Check/Systemd/Native/Prerequisites.pm
@@ -0,0 +1,146 @@
+# systemd/native/prerequisites -- lintian check script -*- perl -*-
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2002 Josip Rodin
+# Copyright (C) 2016-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Systemd::Native::Prerequisites;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(any none);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $EMPTY => q{};
+
+const my $SYSTEMD_NATIVE_PREREQUISITES => 'init-system-helpers:any';
+
+has satisfies_systemd_native_prerequisites => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $pre_depends = $self->processable->relation('Pre-Depends');
+
+ return $pre_depends->satisfies($SYSTEMD_NATIVE_PREREQUISITES);
+ }
+);
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_maintainer_script;
+
+ return
+ unless length $item->interpreter;
+
+ return
+ unless $item->is_open_ok;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $stashed = $EMPTY;
+
+ my $position = 1;
+ while (my $possible_continuation = <$fd>) {
+
+ chomp $possible_continuation;
+
+ # skip empty lines
+ next
+ if $possible_continuation =~ /^\s*$/;
+
+ # skip comment lines
+ next
+ if $possible_continuation =~ /^\s*\#/;
+
+ my $no_comment = remove_comments($possible_continuation);
+
+ # Concatenate lines containing continuation character (\)
+ # at the end
+ if ($no_comment =~ s{\\$}{}) {
+
+ $stashed .= $no_comment;
+
+ next;
+ }
+
+ my $line = $stashed . $no_comment;
+ $stashed = $EMPTY;
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('skip-systemd-native-flag-missing-pre-depends',
+ $pointer,"(does not satisfy $SYSTEMD_NATIVE_PREREQUISITES)")
+ if $line =~ /invoke-rc.d\b.*--skip-systemd-native\b/
+ && !$self->satisfies_systemd_native_prerequisites;
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+sub remove_comments {
+ my ($line) = @_;
+
+ return $line
+ unless length $line;
+
+ my $simplified = $line;
+
+ # Remove quoted strings so we can more easily ignore comments
+ # inside them
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;
+ $simplified =~ s/(^|[^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
+
+ # If the remaining string contains what looks like a comment,
+ # eat it. In either case, swap the unmodified script line
+ # back in for processing (if required) and return it.
+ if ($simplified =~ m/(?:^|[^[\\])[\s\&;\(\)](\#.*$)/) {
+
+ my $comment = $1;
+
+ # eat comment
+ $line =~ s/\Q$comment\E//;
+ }
+
+ return $line;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Systemd/Tmpfiles.pm b/lib/Lintian/Check/Systemd/Tmpfiles.pm
new file mode 100644
index 0000000..dc86628
--- /dev/null
+++ b/lib/Lintian/Check/Systemd/Tmpfiles.pm
@@ -0,0 +1,57 @@
+# systemd -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2013 Michael Stapelberg
+# Copyright (C) 2016-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# based on the apache2 checks file by:
+# Copyright (C) 2012 Arno Toell
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Systemd::Tmpfiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ $self->pointed_hint('systemd-tmpfile-in-var-run', $item->pointer)
+ if $item->name =~ m{^ usr/lib/tmpfiles[.]d/ .* [.]conf $}sx
+ && $item->decoded_utf8 =~ m{^ d \s+ /var/run/ }msx;
+
+ $self->pointed_hint('misplaced-systemd-tmpfiles', $item->pointer)
+ if $item->name =~ m{^ etc/tmpfiles[.]d/ .* [.]conf $}sx
+ && $item->is_file;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Team/PkgJs/Deprecated.pm b/lib/Lintian/Check/Team/PkgJs/Deprecated.pm
new file mode 100644
index 0000000..e04099d
--- /dev/null
+++ b/lib/Lintian/Check/Team/PkgJs/Deprecated.pm
@@ -0,0 +1,76 @@
+# team/pkg-js/deprecated -- lintian check script for deprecated javascript -*- perl -*-
+#
+# Copyright (C) 2019 Xavier Guimard <yadd@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Team::PkgJs::Deprecated;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has javascript_team_maintained => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($boolean) = @_; return ($boolean // 0); },
+ default => sub {
+ my ($self) = @_;
+
+ my $maintainer = $self->processable->fields->value('Maintainer');
+
+ # only for pkg-perl packages
+ return 1
+ if $maintainer
+ =~ /pkg-javascript-maintainers\@lists\.alioth\.debian\.org/;
+
+ return 0;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $self->javascript_team_maintained;
+
+ return
+ unless $item->name =~ /\.js$/;
+
+ my $bytes = $item->bytes;
+ return
+ unless length $bytes;
+
+ $self->pointed_hint('nodejs-bad-buffer-usage', $item->pointer)
+ if $bytes =~ /\bnew\s+Buffer\(/;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Team/PkgJs/Testsuite.pm b/lib/Lintian/Check/Team/PkgJs/Testsuite.pm
new file mode 100644
index 0000000..2920fe0
--- /dev/null
+++ b/lib/Lintian/Check/Team/PkgJs/Testsuite.pm
@@ -0,0 +1,73 @@
+# team/pkg-js/testsuite -- lintian check script for detecting a missing Testsuite header -*- perl -*-
+#
+# Copyright (C) 2013 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2013 gregor herrmann <gregoa@debian.org>
+# Copyright (C) 2014 Niko Tyni <ntyni@debian.org>
+# Copyright (C) 2018 Florian Schlichting <fsfs@debian.org>
+# Copyright (C) 2019 Xavier Guimard <yadd@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Team::PkgJs::Testsuite;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $maintainer = $self->processable->fields->value('Maintainer');
+
+ # only for pkg-perl packages
+ return
+ unless $maintainer
+ =~ /pkg-javascript-maintainers\@lists\.alioth\.debian\.org/;
+
+ unless ($self->processable->fields->declares('Testsuite')) {
+
+ $self->hint('no-testsuite-header');
+ return;
+ }
+
+ my @testsuites
+ = $self->processable->fields->trimmed_list('Testsuite', qr/,/);
+
+ if (none { $_ eq 'autopkgtest-pkg-perl' } @testsuites) {
+
+ $self->hint('no-team-tests');
+ return;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Team/PkgJs/Vcs.pm b/lib/Lintian/Check/Team/PkgJs/Vcs.pm
new file mode 100644
index 0000000..e4d4bec
--- /dev/null
+++ b/lib/Lintian/Check/Team/PkgJs/Vcs.pm
@@ -0,0 +1,78 @@
+# team/pkg-js/debhelper -- lintian check script for checking Vcs-* headers -*- perl -*-
+#
+# Copyright (C) 2013 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2013 gregor herrmann <gregoa@debian.org>
+# Copyright (C) 2013 Axel Beckert <abe@debian.org>
+# Copyright (C) 2019 Xavier Guimard <yadd@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Team::PkgJs::Vcs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my @NON_GIT_VCS_FIELDS
+ = qw(Vcs-Arch Vcs-Bzr Vcs-Cvs Vcs-Darcs Vcs-Hg Vcs-Mtn Vcs-Svn);
+my @VCS_FIELDS = (@NON_GIT_VCS_FIELDS, qw(Vcs-Git Vcs-Browser));
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ # only for pkg-perl packages
+ my $maintainer = $fields->value('Maintainer');
+ return
+ unless $maintainer
+ =~ /pkg-javascript-maintainers\@lists\.alioth\.debian\.org/;
+
+ my @non_git = grep { $fields->declares($_) } @NON_GIT_VCS_FIELDS;
+ $self->hint('no-git', $_) for @non_git;
+
+ # check for team locations
+ for my $name (@VCS_FIELDS) {
+
+ next
+ unless $fields->declares($name);
+
+ my $value = $fields->value($name);
+
+ # get actual capitalization
+ my $original_name = $fields->literal_name($name);
+
+ $self->hint('no-team-url', $original_name, $value)
+ unless $value=~ m{^https://salsa.debian.org/js-team}i;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Team/PkgPerl/Testsuite.pm b/lib/Lintian/Check/Team/PkgPerl/Testsuite.pm
new file mode 100644
index 0000000..2bf6776
--- /dev/null
+++ b/lib/Lintian/Check/Team/PkgPerl/Testsuite.pm
@@ -0,0 +1,78 @@
+# team/pkg-perl/no-testsuite -- lintian check script for detecting a missing Testsuite header -*- perl -*-
+#
+# Copyright (C) 2013 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2013 gregor herrmann <gregoa@debian.org>
+# Copyright (C) 2014 Niko Tyni <ntyni@debian.org>
+# Copyright (C) 2018 Florian Schlichting <fsfs@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Team::PkgPerl::Testsuite;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(none);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ # only for pkg-perl packages
+ my $maintainer = $self->processable->fields->value('Maintainer');
+ return
+ unless $maintainer=~ /pkg-perl-maintainers\@lists\.alioth\.debian\.org/;
+
+ unless ($self->processable->fields->declares('Testsuite')) {
+
+ $self->hint('no-testsuite-header');
+ return;
+ }
+
+ my @testsuites
+ = $self->processable->fields->trimmed_list('Testsuite', qr/,/);
+
+ if (none { $_ eq 'autopkgtest-pkg-perl' } @testsuites) {
+
+ $self->hint('no-team-tests');
+ return;
+ }
+
+ my $metajson = $self->processable->patched->lookup('META.json');
+ my $metayml = $self->processable->patched->lookup('META.yml');
+
+ $self->hint('autopkgtest-needs-use-name')
+ unless (defined $metajson && $metajson->size)
+ || (defined $metayml && $metayml->size)
+ || $self->processable->patched->lookup('debian/tests/pkg-perl/use-name');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Team/PkgPerl/Vcs.pm b/lib/Lintian/Check/Team/PkgPerl/Vcs.pm
new file mode 100644
index 0000000..2818b78
--- /dev/null
+++ b/lib/Lintian/Check/Team/PkgPerl/Vcs.pm
@@ -0,0 +1,77 @@
+# team/pkg-perl/debhelper -- lintian check script for checking Vcs-* headers -*- perl -*-
+#
+# Copyright (C) 2013 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2013 gregor herrmann <gregoa@debian.org>
+# Copyright (C) 2013 Axel Beckert <abe@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Team::PkgPerl::Vcs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+my @NON_GIT_VCS_FIELDS
+ = qw(Vcs-Arch Vcs-Bzr Vcs-Cvs Vcs-Darcs Vcs-Hg Vcs-Mtn Vcs-Svn);
+my @VCS_FIELDS = (@NON_GIT_VCS_FIELDS, qw(Vcs-Git Vcs-Browser));
+
+sub source {
+ my ($self) = @_;
+
+ my $fields = $self->processable->fields;
+
+ # only for pkg-perl packages
+ my $maintainer = $fields->value('Maintainer');
+ return
+ unless $maintainer=~ /pkg-perl-maintainers\@lists\.alioth\.debian\.org/;
+
+ my @non_git = grep { $fields->declares($_) } @NON_GIT_VCS_FIELDS;
+ $self->hint('no-git', $_) for @non_git;
+
+ # check for team locations
+ for my $name (@VCS_FIELDS) {
+
+ next
+ unless $fields->declares($name);
+
+ my $value = $fields->value($name);
+
+ # get actual capitalization
+ my $original_name = $fields->literal_name($name);
+
+ $self->hint('no-team-url', $original_name, $value)
+ unless $value
+ =~ m{^https://salsa\.debian\.org/perl-team/modules/packages}i;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Team/PkgPerl/XsAbi.pm b/lib/Lintian/Check/Team/PkgPerl/XsAbi.pm
new file mode 100644
index 0000000..bb6ea56
--- /dev/null
+++ b/lib/Lintian/Check/Team/PkgPerl/XsAbi.pm
@@ -0,0 +1,95 @@
+# team/pkg-perl/xs-abi -- lintian check script for XS target directory -*- perl -*-
+#
+# Copyright (C) 2014 Damyan Ivanov <dmn@debian.org>
+# Copyright (C) 2014 Axel Beckert <abe@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Team::PkgPerl::XsAbi;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Dpkg::Version;
+
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+has relies_on_modern_api => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($boolean) = @_; return ($boolean // 0); },
+ default => sub {
+ my ($self) = @_;
+
+ return 0
+ if $self->processable->fields->value('Architecture') eq 'all';
+
+ my $depends = $self->processable->relation('strong');
+
+ my $api_version = $depends->visit(
+ sub {
+ my ($prerequisite) = @_;
+
+ if ($prerequisite =~ /^perlapi-(\d[\d.]*)$/) {
+ return $1;
+ }
+
+ return;
+ },
+ Lintian::Relation::VISIT_OR_CLAUSE_FULL
+ | Lintian::Relation::VISIT_STOP_FIRST_MATCH
+ );
+
+ return 0
+ unless defined $api_version;
+
+ return 1
+ if version_compare_relation($api_version, REL_GE, '5.19.11');
+
+ return 0;
+ }
+);
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->is_file;
+
+ return
+ unless $item->name =~ m{^usr/lib/perl5/};
+
+ $self->pointed_hint('legacy-vendorarch-directory', $item->pointer)
+ if $self->relies_on_modern_api;
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Template/DhMake/Control/Vcs.pm b/lib/Lintian/Check/Template/DhMake/Control/Vcs.pm
new file mode 100644
index 0000000..11bf366
--- /dev/null
+++ b/lib/Lintian/Check/Template/DhMake/Control/Vcs.pm
@@ -0,0 +1,77 @@
+# template/dh-make/control/vcs -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Template::DhMake::Control::Vcs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $item = $self->processable->debian_control->item;
+ return
+ unless defined $item;
+
+ my @lines = split(/\n/, $item->decoded_utf8);
+
+ my $line;
+ my $position = 1;
+ while (defined($line = shift @lines)) {
+
+ $line =~ s{\s*$}{};
+
+ if (
+ $line =~ m{\A \# \s* Vcs-(?:Git|Browser): \s*
+ (?:git|http)://git\.debian\.org/
+ (?:\?p=)?collab-maint/<pkg>\.git}smx
+ ) {
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('control-file-contains-dh-make-vcs-comment',
+ $pointer, $line);
+
+ # once per source
+ last;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Testsuite.pm b/lib/Lintian/Check/Testsuite.pm
new file mode 100644
index 0000000..46556e5
--- /dev/null
+++ b/lib/Lintian/Check/Testsuite.pm
@@ -0,0 +1,352 @@
+# testsuite -- lintian check script -*- perl -*-
+
+# Copyright (C) 2013 Nicolas Boulenguez <nicolas@debian.org>
+# Copyright (C) 2017-2020 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+
+# This file is part of lintian.
+
+# Lintian is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+
+# Lintian is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with Lintian. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Check::Testsuite;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+use List::SomeUtils qw(any none uniq);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822;
+use Lintian::Deb822::Constants qw(DCTRL_COMMENTS_AT_EOL);
+use Lintian::Relation;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $DOT => q{.};
+const my $DOUBLE_QUOTE => q{"};
+
+const my @KNOWN_FIELDS => qw(
+ Tests
+ Restrictions
+ Features
+ Depends
+ Tests-Directory
+ Test-Command
+ Architecture
+ Classes
+);
+
+my %KNOWN_FEATURES = map { $_ => 1 } qw();
+
+our $PYTHON3_ALL_DEPEND
+ = 'python3-all:any | python3-all-dev:any | python3-all-dbg:any';
+
+my %KNOWN_SPECIAL_DEPENDS = map { $_ => 1 } qw(
+ @
+ @builddeps@
+ @recommends@
+);
+
+sub source {
+ my ($self) = @_;
+
+ my $KNOWN_TESTSUITES= $self->data->load('testsuite/known-testsuites');
+
+ my $debian_control = $self->processable->debian_control;
+
+ my $testsuite = $debian_control->source_fields->value('Testsuite');
+ my @testsuites = split(/\s*,\s*/, $testsuite);
+
+ my $lc = List::Compare->new(\@testsuites, [$KNOWN_TESTSUITES->all]);
+ my @unknown = $lc->get_Lonly;
+
+ my $control_position
+ = $debian_control->source_fields->position('Testsuite');
+ my $control_pointer = $debian_control->item->pointer($control_position);
+
+ $self->pointed_hint('unknown-testsuite', $control_pointer, $_)for @unknown;
+
+ my $tests_control
+ = $self->processable->patched->resolve_path('debian/tests/control');
+
+ # field added automatically since dpkg 1.17 when d/tests/control is present
+ $self->pointed_hint('unnecessary-testsuite-autopkgtest-field',
+ $control_pointer)
+ if (any { $_ eq 'autopkgtest' } @testsuites) && defined $tests_control;
+
+ # need d/tests/control for plain autopkgtest
+ $self->pointed_hint('missing-tests-control', $control_pointer)
+ if (any { $_ eq 'autopkgtest' } @testsuites) && !defined $tests_control;
+
+ die encode_utf8('debian tests control is not a regular file')
+ if defined $tests_control && !$tests_control->is_regular_file;
+
+ if (defined $tests_control && $tests_control->is_valid_utf8) {
+
+ # another check complains about invalid encoding
+ my $contents = $tests_control->decoded_utf8;
+
+ my $control_file = Lintian::Deb822->new;
+ $control_file->parse_string($contents, DCTRL_COMMENTS_AT_EOL);
+
+ my @sections = @{$control_file->sections};
+
+ $self->pointed_hint('empty-debian-tests-control',
+ $tests_control->pointer)
+ unless @sections;
+
+ $self->check_control_paragraph($tests_control, $_) for @sections;
+
+ my @thorough
+ = grep { $_->value('Restrictions') !~ m{\bsuperficial\b} } @sections;
+ $self->pointed_hint('superficial-tests', $tests_control->pointer)
+ if @sections && !@thorough;
+
+ if (scalar @sections == 1) {
+
+ my $section = $sections[0];
+
+ my $command = $section->unfolded_value('Test-Command');
+ my $position = $section->position('Test-Command');
+ my $pointer = $tests_control->pointer($position);
+
+ $self->pointed_hint('no-op-testsuite', $pointer)
+ if $command =~ m{^ \s* (?:/bin/)? true \s* $}sx;
+ }
+ }
+
+ my $control_autodep8
+ = $self->processable->patched->resolve_path(
+ 'debian/tests/control.autodep8');
+ $self->pointed_hint('debian-tests-control-autodep8-is-obsolete',
+ $control_autodep8->pointer)
+ if defined $control_autodep8;
+
+ return;
+}
+
+sub check_control_paragraph {
+ my ($self, $tests_control, $section) = @_;
+
+ my $section_pointer = $tests_control->pointer($section->position);
+
+ $self->pointed_hint('no-tests', $section_pointer)
+ unless $section->declares('Tests') || $section->declares('Test-Command');
+
+ $self->pointed_hint('conflicting-test-fields', $section_pointer, 'Tests',
+ 'Test-Command')
+ if $section->declares('Tests') && $section->declares('Test-Command');
+
+ my @lowercase_names = map { lc } $section->names;
+ my @lowercase_known = map { lc } @KNOWN_FIELDS;
+
+ my $lc = List::Compare->new(\@lowercase_names, \@lowercase_known);
+ my @lowercase_unknown = $lc->get_Lonly;
+
+ my @unknown = map { $section->literal_name($_) } @lowercase_unknown;
+ $self->pointed_hint('unknown-runtime-tests-field',
+ $tests_control->pointer($section->position($_)), $_)
+ for @unknown;
+
+ my @features = $section->trimmed_list('Features', qr/ \s* , \s* | \s+ /x);
+ for my $feature (@features) {
+
+ my $position = $section->position('Features');
+ my $pointer = $tests_control->pointer($position);
+
+ $self->pointed_hint('unknown-runtime-tests-feature',$pointer, $feature)
+ unless exists $KNOWN_FEATURES{$feature}
+ || $feature =~ m/^test-name=\S+/;
+ }
+
+ my $KNOWN_RESTRICTIONS= $self->data->load('testsuite/known-restrictions');
+ my $KNOWN_OBSOLETE_RESTRICTIONS
+ = $self->data->load('testsuite/known-obsolete-restrictions');
+
+ my @restrictions
+ = $section->trimmed_list('Restrictions', qr/ \s* , \s* | \s+ /x);
+ for my $restriction (@restrictions) {
+
+ my $position = $section->position('Restrictions');
+ my $pointer = $tests_control->pointer($position);
+
+ $self->pointed_hint('unknown-runtime-tests-restriction',
+ $pointer, $restriction)
+ unless $KNOWN_RESTRICTIONS->recognizes($restriction);
+
+ $self->pointed_hint('obsolete-runtime-tests-restriction',
+ $pointer, $restriction)
+ if $KNOWN_OBSOLETE_RESTRICTIONS->recognizes($restriction);
+ }
+
+ my $test_command = $section->unfolded_value('Test-Command');
+
+ # trim both sides
+ $test_command =~ s/^\s+|\s+$//g;
+
+ $self->pointed_hint('backgrounded-test-command',
+ $tests_control->pointer($section->position('Test-Command')),
+ $test_command)
+ if $test_command =~ / & $/x;
+
+ my $directory = $section->unfolded_value('Tests-Directory')
+ || 'debian/tests';
+
+ my $tests_position = $section->position('Tests');
+ my $tests_pointer = $tests_control->pointer($tests_position);
+
+ my @tests = uniq +$section->trimmed_list('Tests', qr/ \s* , \s* | \s+ /x);
+
+ my @illegal_names = grep { !m{^ [ [:alnum:] \+ \- \. / ]+ $}x } @tests;
+ $self->pointed_hint('illegal-runtime-test-name', $tests_pointer, $_)
+ for @illegal_names;
+
+ my @paths;
+ if ($directory eq $DOT) {
+
+ # Special case with "Tests-Directory: ." (see #849880)
+ @paths = @tests;
+
+ } else {
+ @paths = map { "$directory/$_" } @tests;
+ }
+
+ my $debian_control = $self->processable->debian_control;
+
+ my $depends_norestriction = Lintian::Relation->new;
+ $depends_norestriction->load($section->unfolded_value('Depends'));
+
+ my $all_tests_use_supported = 1;
+
+ for my $path (@paths) {
+
+ my $item = $self->processable->patched->resolve_path($path);
+ if (!defined $item) {
+
+ $self->pointed_hint('missing-runtime-test-file', $tests_pointer,
+ $path);
+ next;
+ }
+
+ if (!$item->is_open_ok) {
+
+ $self->pointed_hint('runtime-test-file-is-not-a-regular-file',
+ $tests_pointer, $path);
+ next;
+ }
+
+ my $queries_all_python_versions = 0;
+
+ open(my $fd, '<', $item->unpacked_path)
+ or die encode_utf8('Cannot open ' . $item->unpacked_path);
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ my $pointer = $item->pointer($position);
+
+ $self->pointed_hint('uses-deprecated-adttmp', $pointer)
+ if $line =~ /ADTTMP/;
+
+ if ($line =~ /(py3versions)((?:\s+--?\w+)*)/) {
+
+ my $command = $1 . $2;
+ my $options = $2;
+
+ $self->pointed_hint(
+ 'runtime-test-file-uses-installed-python-versions',
+ $pointer, $command)
+ if $options =~ /\s(?:-\w*i|--installed)/;
+
+ $self->pointed_hint(
+'runtime-test-file-uses-supported-python-versions-without-test-depends',
+ $pointer,
+ $command
+ )
+ if $options =~ /\s(?:-\w*s|--supported)/
+ && !$depends_norestriction->satisfies($PYTHON3_ALL_DEPEND);
+
+ $self->pointed_hint('declare-python-versions-for-test',
+ $pointer, $command)
+ if $options =~ m{ \s (?: -\w*r | --requested ) }x
+ && !$debian_control->source_fields->declares(
+ 'X-Python3-Version');
+
+ $queries_all_python_versions = 1
+ if $options =~ m{ \s (?: -\w*s | --supported ) }x;
+ }
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ $all_tests_use_supported = 0
+ if !$queries_all_python_versions;
+
+ $self->pointed_hint('test-leaves-python-version-untested',
+ $item->pointer)
+ if $depends_norestriction->satisfies($PYTHON3_ALL_DEPEND)
+ && !$queries_all_python_versions;
+ }
+
+ if ( $debian_control->source_fields->declares('X-Python3-Version')
+ && $all_tests_use_supported) {
+
+ my $position
+ = $debian_control->source_fields->position('X-Python3-Version');
+ my $pointer = $debian_control->item->pointer($position);
+
+ $self->pointed_hint('drop-python-version-declaration',$pointer);
+ }
+
+ if ($section->declares('Depends')) {
+
+ my $depends = $section->unfolded_value('Depends');
+
+ # trim both sides
+ $depends =~ s/^\s+|\s+$//g;
+
+ my $relation = Lintian::Relation->new->load($depends);
+
+ # autopkgtest allows @ as predicate as an exception
+ my @unparsable = grep { !exists $KNOWN_SPECIAL_DEPENDS{$_} }
+ $relation->unparsable_predicates;
+
+ my $position = $section->position('Depends');
+ my $pointer = $tests_control->pointer($position);
+
+ $self->pointed_hint('testsuite-dependency-has-unparsable-elements',
+ $pointer, $DOUBLE_QUOTE . $_ . $DOUBLE_QUOTE)
+ for @unparsable;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Triggers.pm b/lib/Lintian/Check/Triggers.pm
new file mode 100644
index 0000000..738f3c6
--- /dev/null
+++ b/lib/Lintian/Check/Triggers.pm
@@ -0,0 +1,145 @@
+# triggers -- lintian check script -*- perl -*-
+
+# Copyright (C) 2017 Niels Thykier
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Triggers;
+
+use v5.20;
+use warnings;
+use utf8;
+use autodie qw(open);
+
+use Const::Fast;
+use List::SomeUtils qw(all);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+const my $SPACE => q{ };
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+has TRIGGER_TYPES => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %trigger_types;
+
+ my $data
+ = $self->data->load('triggers/trigger-types',qr{ \s* => \s* }x);
+ for my $type ($data->all) {
+
+ my $attributes = $data->value($type);
+
+ my %one_type;
+
+ for my $pair (split(m{ \s* , \s* }x, $attributes)) {
+
+ my ($flag, $setting) = split(m{ \s* = \s* }x, $pair, 2);
+ $one_type{$flag} = $setting;
+ }
+
+ die encode_utf8(
+"Invalid trigger-types: $type is defined as implicit-await but not await"
+ )
+ if $one_type{'implicit-await'}
+ && !$one_type{await};
+
+ $trigger_types{$type} = \%one_type;
+ }
+
+ return \%trigger_types;
+ }
+);
+
+sub visit_control_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name eq 'triggers';
+
+ my @lines = split(m{\n}, $item->decoded_utf8);
+
+ my %positions_by_trigger_name;
+
+ my $position = 1;
+ while (defined(my $line = shift @lines)) {
+
+ # trim both ends
+ $line =~ s/^\s+|\s+$//g;
+
+ next
+ if $line =~ m/^(?:\s*)(?:#.*)?$/;
+
+ my ($trigger_type, $trigger_name) = split($SPACE, $line, 2);
+ next
+ unless all { length } ($trigger_type, $trigger_name);
+
+ $positions_by_trigger_name{$trigger_name} //= [];
+ push(@{$positions_by_trigger_name{$trigger_name}}, $position);
+
+ my $trigger_info = $self->TRIGGER_TYPES->{$trigger_type};
+ if (!$trigger_info) {
+
+ $self->pointed_hint('unknown-trigger', $item->pointer($position),
+ $trigger_type);
+ next;
+ }
+
+ $self->pointed_hint('uses-implicit-await-trigger',
+ $item->pointer($position),
+ $trigger_type)
+ if $trigger_info->{'implicit-await'};
+
+ } continue {
+ ++$position;
+ }
+
+ my @duplicates= grep { @{$positions_by_trigger_name{$_}} > 1 }
+ keys %positions_by_trigger_name;
+
+ for my $trigger_name (@duplicates) {
+
+ my $indicator
+ = $LEFT_PARENTHESIS . 'lines'
+ . $SPACE
+ . join($SPACE,
+ sort { $a <=> $b }@{$positions_by_trigger_name{$trigger_name}})
+ . $RIGHT_PARENTHESIS;
+
+ $self->pointed_hint('repeated-trigger-name', $item->pointer,
+ $trigger_name, $indicator);
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Udev.pm b/lib/Lintian/Check/Udev.pm
new file mode 100644
index 0000000..4d1779a
--- /dev/null
+++ b/lib/Lintian/Check/Udev.pm
@@ -0,0 +1,172 @@
+# udev -- lintian check script -*- perl -*-
+
+# Copyright (C) 2016 Petter Reinholdtsen
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Udev;
+
+use v5.20;
+use warnings;
+use utf8;
+use autodie qw(open);
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+# Check /lib/udev/rules.d/, detect use of MODE="0666" and use of
+# GROUP="plugdev" without TAG+="uaccess".
+
+sub installable {
+ my ($self) = @_;
+
+ foreach my $lib_dir (qw(usr/lib lib)) {
+ my $rules_dir
+ = $self->processable->installed->resolve_path(
+ "$lib_dir/udev/rules.d/");
+ next
+ unless $rules_dir;
+
+ for my $item ($rules_dir->children) {
+
+ if (!$item->is_open_ok) {
+
+ $self->pointed_hint('udev-rule-unreadable', $item->pointer);
+ next;
+ }
+
+ $self->check_udev_rules($item);
+ }
+ }
+
+ return;
+}
+
+sub check_rule {
+ my ($self, $item, $position, $in_goto, $rule) = @_;
+
+ # for USB, if everyone or the plugdev group members are
+ # allowed access, the uaccess tag should be used too.
+ $self->pointed_hint(
+ 'udev-rule-missing-uaccess',
+ $item->pointer($position),
+ 'user accessible device missing TAG+="uaccess"'
+ )
+ if $rule =~ m/SUBSYSTEM=="usb"/
+ && ( $rule =~ m/GROUP="plugdev"/
+ || $rule =~ m/MODE="0666"/)
+ && $rule !~ m/ENV\{COLOR_MEASUREMENT_DEVICE\}/
+ && $rule !~ m/ENV\{DDC_DEVICE\}/
+ && $rule !~ m/ENV\{ID_CDROM\}/
+ && $rule !~ m/ENV\{ID_FFADO\}/
+ && $rule !~ m/ENV\{ID_GPHOTO2\}/
+ && $rule !~ m/ENV\{ID_HPLIP\}/
+ && $rule !~ m/ENV\{ID_INPUT_JOYSTICK\}/
+ && $rule !~ m/ENV\{ID_MAKER_TOOL\}/
+ && $rule !~ m/ENV\{ID_MEDIA_PLAYER\}/
+ && $rule !~ m/ENV\{ID_PDA\}/
+ && $rule !~ m/ENV\{ID_REMOTE_CONTROL\}/
+ && $rule !~ m/ENV\{ID_SECURITY_TOKEN\}/
+ && $rule !~ m/ENV\{ID_SMARTCARD_READER\}/
+ && $rule !~ m/ENV\{ID_SOFTWARE_RADIO\}/
+ && $rule !~ m/TAG\+="uaccess"/;
+
+ # Matching rules mentioning vendor/product should also specify
+ # subsystem, as vendor/product is subsystem specific.
+ $self->pointed_hint(
+ 'udev-rule-missing-subsystem',
+ $item->pointer($position),
+ 'vendor/product matching missing SUBSYSTEM specifier'
+ )
+ if $rule =~ m/ATTR\{idVendor\}=="[0-9a-fA-F]+"/
+ && $rule =~ m/ATTR\{idProduct\}=="[0-9a-fA-F]*"/
+ && !$in_goto
+ && $rule !~ m/SUBSYSTEM=="[^"]+"/;
+
+ return 0;
+}
+
+sub check_udev_rules {
+ my ($self, $item) = @_;
+
+ my $contents = $item->decoded_utf8;
+ my @lines = split(/\n/, $contents);
+
+ my $continued = $EMPTY;
+ my $in_goto = $EMPTY;
+ my $result = 0;
+
+ my $position = 1;
+ while (defined(my $line = shift @lines)) {
+
+ if (length $continued) {
+ $line = $continued . $line;
+ $continued = $EMPTY;
+ }
+
+ if ($line =~ /^(.*)\\$/) {
+ $continued = $1;
+ next;
+ }
+
+ # Skip comments
+ next
+ if $line =~ /^#.*/;
+
+ $in_goto = $EMPTY
+ if $line =~ /LABEL="[^"]+"/;
+
+ $in_goto = $line
+ if $line =~ /SUBSYSTEM!="[^"]+"/
+ && $line =~ /GOTO="[^"]+"/;
+
+ $result |= $self->check_rule($item, $position, $in_goto, $line);
+
+ } continue {
+ $position++;
+ }
+
+ return $result;
+}
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^etc/udev/};
+
+ # /etc/udev/rules.d
+ $self->pointed_hint('udev-rule-in-etc', $item->pointer)
+ if $item->name =~ m{^etc/udev/rules\.d/\S};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Unpack.pm b/lib/Lintian/Check/Unpack.pm
new file mode 100644
index 0000000..9395942
--- /dev/null
+++ b/lib/Lintian/Check/Unpack.pm
@@ -0,0 +1,67 @@
+# unpack -- lintian check script -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Unpack;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ $self->hint('unpack-message-for-source', $_)
+ for @{$processable->patched->unpack_messages};
+
+ # empty for native
+ $self->hint('unpack-message-for-orig', $_)
+ for @{$processable->orig->unpack_messages};
+
+ return;
+}
+
+sub installable {
+ my ($self) = @_;
+
+ my $processable = $self->processable;
+
+ $self->hint('unpack-message-for-deb-data', $_)
+ for @{$processable->installed->unpack_messages};
+
+ $self->hint('unpack-message-for-deb-control', $_)
+ for @{$processable->control->unpack_messages};
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/UpstreamSignature.pm b/lib/Lintian/Check/UpstreamSignature.pm
new file mode 100644
index 0000000..3278e87
--- /dev/null
+++ b/lib/Lintian/Check/UpstreamSignature.pm
@@ -0,0 +1,126 @@
+# upstream-signature -- lintian check script -*- perl -*-
+#
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::UpstreamSignature;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub source {
+ my ($self) = @_;
+
+ my $SIGNING_KEY_FILENAMES
+ = $self->data->load('common/signing-key-filenames');
+
+ my @keynames = $SIGNING_KEY_FILENAMES->all;
+ my @keypaths
+ = map { $self->processable->patched->resolve_path("debian/$_") }
+ @keynames;
+ my @keys = grep { $_ && $_->is_file } @keypaths;
+
+ # in uscan's gittag mode,signature will never match
+ my $watch = $self->processable->patched->resolve_path('debian/watch');
+ my $gittag = $watch && $watch->bytes =~ /pgpmode=gittag/;
+
+ my @filenames = sort keys %{$self->processable->files};
+ my @origtar= grep { /^.*\.orig(?:-[A-Za-z\d-]+)?\.tar\./ }
+ grep { !/\.asc$/ }@filenames;
+
+ my %signatures;
+ for my $filename (@origtar) {
+
+ my ($uncompressed) = ($filename =~ /(^.*\.tar)/);
+
+ my @componentsigs;
+ for my $tarball ($filename, $uncompressed) {
+ my $signaturename = "$tarball.asc";
+ push(@componentsigs, $signaturename)
+ if exists $self->processable->files->{$signaturename};
+ }
+
+ $signatures{$filename} = \@componentsigs;
+ }
+
+ # orig tarballs should be signed if upstream's public key is present
+ if (@keys && !$self->processable->repacked && !$gittag) {
+
+ for my $filename (@origtar) {
+
+ $self->hint('orig-tarball-missing-upstream-signature', $filename)
+ unless scalar @{$signatures{$filename}};
+ }
+ }
+
+ my $parentdir = path($self->processable->path)->parent->stringify;
+
+ # check signatures
+ my @allsigs = map { @{$signatures{$_}} } @origtar;
+ for my $signature (@allsigs) {
+ my $sig_file = path($parentdir)->child($signature);
+ # Only try to slurp file if it exists. Otherwise Path::Tiny ≥
+ # 0.142 will bail out. (Returned empty string instead before
+ # that version.)
+ next unless $sig_file->is_file;
+
+ # take from location near input file
+ my $contents = $sig_file->slurp;
+
+ if ($contents =~ /^-----BEGIN PGP ARMORED FILE-----/m) {
+
+ if ($contents =~ /^LS0tLS1CRUd/m) {
+ # doubly armored
+ $self->hint('doubly-armored-upstream-signature', $signature);
+
+ } else {
+ # non standard armored header
+ $self->hint('explicitly-armored-upstream-signature',
+ $signature);
+ }
+
+ my @spurious = ($contents =~ /\n([^:\n]+):/g);
+ $self->hint('spurious-fields-in-upstream-signature',
+ $signature, @spurious)
+ if @spurious;
+ }
+
+ # multiple signatures in one file
+ $self->hint('concatenated-upstream-signatures', $signature)
+ if $contents
+ =~ m/(?:-----BEGIN PGP SIGNATURE-----[^-]*-----END PGP SIGNATURE-----\s*){2,}/;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Usrmerge.pm b/lib/Lintian/Check/Usrmerge.pm
new file mode 100644
index 0000000..a435470
--- /dev/null
+++ b/lib/Lintian/Check/Usrmerge.pm
@@ -0,0 +1,66 @@
+# usrmerge -- lintian check script -*- perl -*-
+
+# Copyright (C) 2016 Marco d'Itri
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Usrmerge;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ return
+ unless $item->name =~ m{^(?:s?bin|lib(?:|[ox]?32|64))/};
+
+ my $usrfile = $self->processable->installed->lookup("usr/$item");
+
+ return
+ unless defined $usrfile;
+
+ return
+ if $item->is_dir and $usrfile->is_dir;
+
+ if ($item =~ m{^lib.+\.(?:so[\.0-9]*|a)$}) {
+ $self->pointed_hint('library-in-root-and-usr', $item->pointer,
+ 'already in:', $usrfile->name);
+
+ } else {
+ $self->pointed_hint(
+ 'file-in-root-and-usr', $item->pointer,
+ 'already in:', $usrfile->name
+ );
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Vim.pm b/lib/Lintian/Check/Vim.pm
new file mode 100644
index 0000000..ef889f5
--- /dev/null
+++ b/lib/Lintian/Check/Vim.pm
@@ -0,0 +1,53 @@
+# vim -- lintian check script -*- perl -*-
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Vim;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub visit_installed_files {
+ my ($self, $item) = @_;
+
+ if ($item->name =~ m{^usr/share/vim/vim(?:current|\d\d)/([^/]+)}){
+ my $is_vimhelp
+ = $1 eq 'doc' && $self->processable->name =~ /^vimhelp-\w+$/;
+ my $is_vim = $self->processable->source_name =~ /vim/;
+
+ $self->pointed_hint('vim-addon-within-vim-runtime-path',$item->pointer)
+ unless $is_vim || $is_vimhelp;
+ }
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Check/Vim/Addons.pm b/lib/Lintian/Check/Vim/Addons.pm
new file mode 100644
index 0000000..9823f0c
--- /dev/null
+++ b/lib/Lintian/Check/Vim/Addons.pm
@@ -0,0 +1,48 @@
+# vim -- lintian check script -*- perl -*-
+
+# Copyright (C) Louis-Philippe Veronneau
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Check::Vim::Addons;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Check';
+
+sub installable {
+ my ($self) = @_;
+
+ $self->hint('obsolete-vim-addon-manager')
+ if $self->processable->relation('strong')
+ ->satisfies('vim-addon-manager');
+
+ return;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Conffiles.pm b/lib/Lintian/Conffiles.pm
new file mode 100644
index 0000000..1daa2c4
--- /dev/null
+++ b/lib/Lintian/Conffiles.pm
@@ -0,0 +1,162 @@
+# -*- perl -*- Lintian::Processable::Installable::Conffiles
+#
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Conffiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Conffiles::Entry;
+
+const my $SPACE => q{ };
+const my $NEWLINE => qq{\n};
+
+const my $TRUE => 1;
+const my $FALSE => 0;
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Conffiles - access to collected control data for conffiles
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Conffiles provides an interface to control data for conffiles.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item by_file
+
+=cut
+
+has by_file => (is => 'rw', default => sub { {} });
+
+=item parse
+
+=cut
+
+sub parse {
+ my ($self, $item) = @_;
+
+ return
+ unless $item && $item->is_valid_utf8;
+
+ my @lines = split($NEWLINE, $item->decoded_utf8);
+
+ # dpkg strips whitespace (using isspace) from the right hand
+ # side of the file name.
+
+ # trim right
+ s/\s+$// for @lines;
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ next
+ unless length $line;
+
+ my @words = split($SPACE, $line);
+ my $relative = pop @words;
+
+ my $conffile = Lintian::Conffiles::Entry->new;
+
+ # path must be absolute
+ if ($relative =~ s{^ / }{}x) {
+ $conffile->is_relative($FALSE);
+ } else {
+ $conffile->is_relative($TRUE);
+ }
+
+ $conffile->instructions(\@words);
+ $conffile->position($position);
+
+ # but use relative path as key
+ $self->by_file->{$relative} //= [];
+ push(@{$self->by_file->{$relative}}, $conffile);
+
+ } continue {
+ ++$position;
+ }
+
+ return;
+}
+
+=item all
+
+Returns a list of absolute filenames found for conffiles.
+
+=cut
+
+sub all {
+ my ($self) = @_;
+
+ return keys %{$self->by_file};
+}
+
+=item is_known (FILE)
+
+Returns a truth value if FILE is listed in the conffiles control file.
+If the control file is not present or FILE is not listed in it, it
+returns C<undef>.
+
+Note that FILE should be the filename relative to the package root
+(even though the control file uses absolute paths). If the control
+file does relative paths, they are assumed to be relative to the
+package root as well (and used without warning).
+
+=cut
+
+sub is_known {
+ my ($self, $relative) = @_;
+
+ return 1
+ if exists $self->by_file->{$relative};
+
+ return 0;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Conffiles/Entry.pm b/lib/Lintian/Conffiles/Entry.pm
new file mode 100644
index 0000000..488cd99
--- /dev/null
+++ b/lib/Lintian/Conffiles/Entry.pm
@@ -0,0 +1,72 @@
+# -*- perl -*- Lintian::Conffiles::Entry
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Conffiles::Entry;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Conffiles::Entry - access to collected control data for conffiles
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Conffiles::Entry provides an interface to control data for conffiles.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item instructions
+=item is_relative
+=item position
+
+=cut
+
+has instructions => (is => 'rw', default => sub { [] });
+has is_relative => (is => 'rw');
+has position => (is => 'rw');
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data.pm b/lib/Lintian/Data.pm
new file mode 100644
index 0000000..6a0b227
--- /dev/null
+++ b/lib/Lintian/Data.pm
@@ -0,0 +1,354 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+# Copyright (C) 2022 Axel Beckert
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Data;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Data::Architectures;
+use Lintian::Data::Archive::AutoRejection;
+use Lintian::Data::Archive::Sections;
+use Lintian::Data::Buildflags::Hardening;
+use Lintian::Data::Debhelper::Addons;
+use Lintian::Data::Debhelper::Commands;
+use Lintian::Data::Debhelper::Levels;
+use Lintian::Data::Fonts;
+use Lintian::Data::InitD::VirtualFacilities;
+use Lintian::Data::Policy::Releases;
+use Lintian::Data::Provides::MailTransportAgent;
+use Lintian::Data::Stylesheet;
+use Lintian::Data::Traditional;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::Authorities';
+
+=head1 NAME
+
+Lintian::Data - Data parser for Lintian
+
+=head1 SYNOPSIS
+
+ my $profile = Lintian::Data->new (vendor => 'debian');
+
+=head1 DESCRIPTION
+
+Lintian::Data handles finding, parsing and implementation of Lintian Data
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item vendor
+
+=item data_paths
+
+=item data_cache
+
+=cut
+
+has vendor => (is => 'rw');
+
+has data_paths => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+has data_cache => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $location, $separator) = @_;
+
+ croak encode_utf8('no data type specified')
+ unless $location;
+
+ unless (exists $self->data_cache->{$location}) {
+
+ my $cache = Lintian::Data::Traditional->new;
+ $cache->location($location);
+ $cache->separator($separator);
+
+ $cache->load($self->data_paths, $self->vendor);
+
+ $self->data_cache->{$location} = $cache;
+ }
+
+ return $self->data_cache->{$location};
+}
+
+=item all_sources
+
+=cut
+
+sub all_sources {
+ my ($self) = @_;
+
+ my @sources = (
+ $self->architectures,$self->auto_rejection,
+ $self->debhelper_addons,$self->debhelper_commands,
+ $self->debhelper_levels,$self->fonts,
+ $self->hardening_buildflags,$self->mail_transport_agents,
+ $self->policy_releases,$self->sections,
+ #$self->style_sheet,
+ $self->virtual_initd_facilities
+ );
+
+ return @sources;
+}
+
+=item architectures
+
+=cut
+
+has architectures => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $architectures = Lintian::Data::Architectures->new;
+ $architectures->load($self->data_paths, $self->vendor);
+
+ return $architectures;
+ }
+);
+
+=item auto_rejection
+
+=cut
+
+has auto_rejection => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $auto_rejection = Lintian::Data::Archive::AutoRejection->new;
+ $auto_rejection->load($self->data_paths, $self->vendor);
+
+ return $auto_rejection;
+ }
+);
+
+=item debhelper_addons
+
+=cut
+
+has debhelper_addons => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $addons = Lintian::Data::Debhelper::Addons->new;
+ $addons->load($self->data_paths, $self->vendor);
+
+ return $addons;
+ }
+);
+
+=item debhelper_commands
+
+=cut
+
+has debhelper_commands => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $commands = Lintian::Data::Debhelper::Commands->new;
+ $commands->load($self->data_paths, $self->vendor);
+
+ return $commands;
+ }
+);
+
+=item debhelper_levels
+
+=cut
+
+has debhelper_levels => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $levels = Lintian::Data::Debhelper::Levels->new;
+ $levels->load($self->data_paths, $self->vendor);
+
+ return $levels;
+ }
+);
+
+=item fonts
+
+=cut
+
+has fonts => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $fonts = Lintian::Data::Fonts->new;
+ $fonts->load($self->data_paths, $self->vendor);
+
+ return $fonts;
+ }
+);
+
+=item hardening_buildflags
+
+=cut
+
+has hardening_buildflags => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $buildflags = Lintian::Data::Buildflags::Hardening->new;
+ $buildflags->load($self->data_paths, $self->vendor);
+
+ return $buildflags;
+ }
+);
+
+=item mail_transport_agents
+
+=cut
+
+has mail_transport_agents => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Provides::MailTransportAgent->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item policy_releases
+
+=cut
+
+has policy_releases => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $releases = Lintian::Data::Policy::Releases->new;
+ $releases->load($self->data_paths, $self->vendor);
+
+ return $releases;
+ }
+);
+
+=item sections
+
+=cut
+
+has sections => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $sections = Lintian::Data::Archive::Sections->new;
+ $sections->load($self->data_paths, $self->vendor);
+
+ return $sections;
+ }
+);
+
+=item style_sheet
+
+=cut
+
+has style_sheet => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $stylesheets = Lintian::Data::Stylesheet->new;
+ $stylesheets->load($self->data_paths, $self->vendor);
+
+ return $stylesheets;
+ }
+);
+
+=item virtual_initd_facilities
+
+=cut
+
+has virtual_initd_facilities => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $facilities = Lintian::Data::InitD::VirtualFacilities->new;
+ $facilities->load($self->data_paths, $self->vendor);
+
+ return $facilities;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Architectures.pm b/lib/Lintian/Data/Architectures.pm
new file mode 100644
index 0000000..c45ced4
--- /dev/null
+++ b/lib/Lintian/Data/Architectures.pm
@@ -0,0 +1,441 @@
+# -*- perl -*-
+
+# Copyright (C) 2011-2012 Niels Thykier <niels@thykier.net>
+# - Based on a shell script by Raphael Geissert <atomo64@gmail.com>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Architectures;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(first_value);
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+const my $HOST_VARIABLES => q{host_variables};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=encoding utf-8
+
+=head1 NAME
+
+Lintian::Data::Architectures -- Lintian API for handling architectures and wildcards
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Architectures;
+
+=head1 DESCRIPTION
+
+Lintian API for checking and expanding architectures and architecture
+wildcards. The functions are backed by a L<data|Lintian::Data> file,
+so it may be out of date (use private/refresh-archs to update it).
+
+Generally all architecture names are in the format "$os-$architecture" and
+wildcards are "$os-any" or "any-$cpu", though there are exceptions:
+
+Note that the architecture and cpu name are not always identical
+(example architecture "armhf" has cpu name "arm").
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item host_variables
+
+=item C<wildcards>
+
+=item C<names>
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'DEB_HOST_* Variables from Dpkg'
+);
+
+has location => (
+ is => 'rw',
+ default => 'architectures/host.json'
+);
+
+has host_variables => (
+ is => 'rw',
+ default => sub { {} },
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); }
+);
+
+has deb_host_multiarch => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my %deb_host_multiarch;
+
+ $deb_host_multiarch{$_}
+ = $self->host_variables->{$_}{DEB_HOST_MULTIARCH}
+ for keys %{$self->host_variables};
+
+ return \%deb_host_multiarch;
+ }
+);
+
+# The list of directories searched by default by the dynamic linker.
+# Packages installing shared libraries into these directories must call
+# ldconfig, must have shlibs files, and must ensure those libraries have
+# proper SONAMEs.
+#
+# Directories listed here must not have leading slashes.
+#
+# On the topic of multi-arch dirs. Hopefully including the ones not
+# native to the local platform won't hurt.
+#
+# See Bug#469301 and Bug#464796 for more details.
+#
+has ldconfig_folders => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my @multiarch = values %{$self->deb_host_multiarch};
+ my @ldconfig_folders = map { ("lib/$_", "usr/lib/$_") } @multiarch;
+
+ my @always = qw{
+ lib
+ lib32
+ lib64
+ libx32
+ usr/lib
+ usr/lib32
+ usr/lib64
+ usr/libx32
+ usr/local/lib
+ };
+ push(@ldconfig_folders, @always);
+
+ my @with_slash = map { $_ . $SLASH } @ldconfig_folders;
+
+ return \@with_slash;
+ }
+);
+
+# Valid architecture wildcards.
+has wildcards => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my %wildcards;
+
+ for my $hyphenated (keys %{$self->host_variables}) {
+
+ my $variables = $self->host_variables->{$hyphenated};
+
+ # NB: "$os-$cpu" is not always equal to $hyphenated
+ my $abi = $variables->{DEB_HOST_ARCH_ABI};
+ my $libc = $variables->{DEB_HOST_ARCH_LIBC};
+ my $os = $variables->{DEB_HOST_ARCH_OS};
+ my $cpu = $variables->{DEB_HOST_ARCH_CPU};
+
+ # map $os-any (e.g. "linux-any") and any-$architecture (e.g. "any-amd64") to
+ # the relevant architectures.
+ $wildcards{'any'}{$hyphenated} = 1;
+
+ $wildcards{'any-any'}{$hyphenated} = 1;
+ $wildcards{"any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$os-any"}{$hyphenated} = 1;
+
+ $wildcards{'any-any-any'}{$hyphenated} = 1;
+ $wildcards{"any-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-$os-any"}{$hyphenated} = 1;
+ $wildcards{"any-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$libc-any-any"}{$hyphenated} = 1;
+ $wildcards{"$libc-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$libc-$os-any"}{$hyphenated} = 1;
+
+ $wildcards{'any-any-any-any'}{$hyphenated} = 1;
+ $wildcards{"any-any-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-any-$os-any"}{$hyphenated} = 1;
+ $wildcards{"any-any-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-any-any"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-$os-any"}{$hyphenated} = 1;
+ $wildcards{"any-$libc-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-any-any"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-$os-any"}{$hyphenated} = 1;
+ $wildcards{"$abi-any-$os-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-$libc-any-any"}{$hyphenated} = 1;
+ $wildcards{"$abi-$libc-any-$cpu"}{$hyphenated} = 1;
+ $wildcards{"$abi-$libc-$os-any"}{$hyphenated} = 1;
+ }
+
+ return \%wildcards;
+ }
+);
+
+# Maps aliases to the "original" arch name.
+# (e.g. "linux-amd64" => "amd64")
+has names => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub {
+ my ($self) = @_;
+
+ my %names;
+
+ for my $hyphenated (keys %{$self->host_variables}) {
+
+ my $variables = $self->host_variables->{$hyphenated};
+
+ $names{$hyphenated} = $hyphenated;
+
+ # NB: "$os-$cpu" ne $hyphenated in some cases
+ my $os = $variables->{DEB_HOST_ARCH_OS};
+ my $cpu = $variables->{DEB_HOST_ARCH_CPU};
+
+ if ($os eq 'linux') {
+
+ # Per Policy section 11.1 (3.9.3):
+ #
+ #"""[architecture] strings are in the format "os-arch", though
+ # the OS part is sometimes elided, as when the OS is Linux."""
+ #
+ # i.e. "linux-amd64" and "amd64" are aliases, so handle them
+ # as such. Currently, dpkg-architecture -L gives us "amd64"
+ # but in case it changes to "linux-amd64", we are prepared.
+
+ if ($hyphenated =~ /^linux-/) {
+ # It may be temping to use $cpu here, but it does not work
+ # for (e.g.) arm based architectures. Instead extract the
+ # "short" architecture name from $hyphenated
+ my (undef, $short) = split(/-/, $hyphenated, 2);
+ $names{$short} = $hyphenated;
+
+ } else {
+ # short string in $hyphenated
+ my $long = "$os-$hyphenated";
+ $names{$long} = $hyphenated;
+ }
+ }
+ }
+
+ return \%names;
+ }
+);
+
+=item is_wildcard ($wildcard)
+
+Returns a truth value if $wildcard is a known architecture wildcard.
+
+Note: 'any' is considered a wildcard and not an architecture.
+
+=cut
+
+sub is_wildcard {
+ my ($self, $wildcard) = @_;
+
+ return exists $self->wildcards->{$wildcard};
+}
+
+=item is_release_architecture ($architecture)
+
+Returns a truth value if $architecture is (an alias of) a Debian machine
+architecture. It returns a false value for
+architecture wildcards (including "any") and unknown architectures.
+
+=cut
+
+sub is_release_architecture {
+ my ($self, $architecture) = @_;
+
+ return exists $self->names->{$architecture};
+}
+
+=item expand_wildcard ($wildcard)
+
+Returns a list of architectures that this wildcard expands to. No
+order is guaranteed (even between calls). Returned values must not be
+modified.
+
+Note: This list is based on the architectures in Lintian's data file.
+However, many of these are not supported or used in Debian or any of
+its derivatives.
+
+The returned values matches the list generated by dpkg-architecture -L,
+so the returned list may use (e.g.) "amd64" for "linux-amd64".
+
+=cut
+
+sub expand_wildcard {
+ my ($self, $wildcard) = @_;
+
+ return keys %{ $self->wildcards->{$wildcard} // {} };
+}
+
+=item wildcard_includes ($wildcard, $architecture)
+
+Returns a truth value if $architecture is included in the list of
+architectures that $wildcard expands to.
+
+This is generally faster than
+
+ grep { $_ eq $architecture } expand_arch_wildcard ($wildcard)
+
+It also properly handles cases like "linux-amd64" and "amd64" being
+aliases.
+
+=cut
+
+sub wildcard_includes {
+ my ($self, $wildcard, $architecture) = @_;
+
+ $architecture = $self->names->{$architecture}
+ if exists $self->names->{$architecture};
+
+ return exists $self->wildcards->{$wildcard}{$architecture};
+}
+
+=item valid_restriction
+
+=cut
+
+sub valid_restriction {
+ my ($self, $restriction) = @_;
+
+ # strip any negative prefix
+ $restriction =~ s/^!//;
+
+ return
+ $self->is_release_architecture($restriction)
+ || $self->is_wildcard($restriction)
+ || $restriction eq 'all';
+}
+
+=item restriction_matches
+
+=cut
+
+sub restriction_matches {
+ my ($self, $restriction, $architecture) = @_;
+
+ # look for negative prefix and strip
+ my $match_wanted = !($restriction =~ s/^!//);
+
+ return $match_wanted
+ if $restriction eq $architecture;
+
+ return $match_wanted
+ if $self->is_wildcard($restriction)
+ && $self->wildcard_includes($restriction, $architecture);
+
+ return !$match_wanted;
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $host_variables;
+
+ return 0
+ unless $self->read_file($path, \$host_variables);
+
+ $self->host_variables($host_variables);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ local $ENV{LC_ALL} = 'C';
+ delete local $ENV{DEB_HOST_ARCH};
+
+ my @architectures
+ = split(/\n/, decode_utf8(safe_qx(qw{dpkg-architecture --list-known})));
+ chomp for @architectures;
+
+ my %host_variables;
+ for my $architecture (@architectures) {
+
+ my @lines= split(
+ /\n/,
+ decode_utf8(
+ safe_qx(qw{dpkg-architecture --host-arch}, $architecture)
+ )
+ );
+
+ for my $line (@lines) {
+ my ($key, $value) = split(/=/, $line, 2);
+
+ $host_variables{$architecture}{$key} = $value
+ if $key =~ /^DEB_HOST_/;
+ }
+ }
+
+ $self->cargo('host_variables');
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status
+ = $self->write_file($HOST_VARIABLES, \%host_variables, $data_path);
+
+ return $status;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Archive/AutoRejection.pm b/lib/Lintian/Data/Archive/AutoRejection.pm
new file mode 100644
index 0000000..d05ae51
--- /dev/null
+++ b/lib/Lintian/Data/Archive/AutoRejection.pm
@@ -0,0 +1,154 @@
+# -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Archive::AutoRejection;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(carp);
+use Const::Fast;
+use HTTP::Tiny;
+use List::SomeUtils qw(first_value uniq);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use YAML::XS qw(LoadFile);
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Data::Archive::AutoRejection - Lintian interface to the archive's auto-rejection tags
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Archive::AutoRejection;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for the archive's auto-rejection tags
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item certain
+
+=item preventable
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Archive Auto-Rejection Tags'
+);
+
+has location => (
+ is => 'rw',
+ default => 'archive/auto-rejection.yaml'
+);
+
+has certain => (is => 'rw', default => sub { [] });
+has preventable => (is => 'rw', default => sub { [] });
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ unless (length $path) {
+ carp encode_utf8('Unknown data file: ' . $self->location);
+ return;
+ }
+
+ my $yaml = LoadFile($path);
+ die encode_utf8('Could not parse YAML file ' . $self->location)
+ unless defined $yaml;
+
+ my $base = $yaml->{lintian};
+ die encode_utf8('Could not parse document base for ' . $self->location)
+ unless defined $base;
+
+ my @certain = uniq @{ $base->{fatal} // [] };
+ my @preventable = uniq @{ $base->{nonfatal} // [] };
+
+ $self->certain(\@certain);
+ $self->preventable(\@preventable);
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $auto_rejection_url
+ = 'https://ftp-master.debian.org/static/lintian.tags';
+
+ my $response = HTTP::Tiny->new->get($auto_rejection_url);
+ die encode_utf8("Failed to get $auto_rejection_url!\n")
+ unless $response->{success};
+
+ my $auto_rejection_yaml = $response->{content};
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ # already in UTF-8
+ path($data_path)->spew($auto_rejection_yaml);
+
+ return 1;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Archive/Sections.pm b/lib/Lintian/Data/Archive/Sections.pm
new file mode 100644
index 0000000..24a99c7
--- /dev/null
+++ b/lib/Lintian/Data/Archive/Sections.pm
@@ -0,0 +1,133 @@
+# -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+# Copyright (C) 2022 Axel Beckert
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Archive::Sections;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(carp);
+use Const::Fast;
+use HTTP::Tiny;
+use List::SomeUtils qw(first_value uniq);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use Lintian::Deb822;
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Archive::Sections - Lintian interface to the archive's sections
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Archive::Sections;
+
+=head1 DESCRIPTION
+
+This module provides a way to load the data file for the archive's section.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Archive Sections'
+);
+
+=item location
+
+=cut
+
+has location => (
+ is => 'rw',
+ default => 'fields/archive-sections'
+);
+
+=item separator
+
+=cut
+
+has separator => (is => 'rw');
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $sections_url = 'https://metadata.ftp-master.debian.org/sections.822';
+
+ my $response = HTTP::Tiny->new->get($sections_url);
+ die encode_utf8("Failed to get $sections_url!\n")
+ unless $response->{success};
+
+ my $sections_822 = $response->{content};
+
+ # TODO: We should probably save this in the original format and
+ # parse it with Lintian::Deb822 at some time.
+ my $sections = join("\n",
+ map { s/^Section: //r }
+ grep { m{^Section: [^/]*$} }
+ split(/\n/, $sections_822))
+ ."\n";
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ # already in UTF-8
+ path($data_path)->spew($sections);
+
+ return 1;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Axel Beckert <abe@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authorities.pm b/lib/Lintian/Data/Authorities.pm
new file mode 100644
index 0000000..fdb77cd
--- /dev/null
+++ b/lib/Lintian/Data/Authorities.pm
@@ -0,0 +1,330 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Data::Authorities;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Data::Authority::DebconfSpecification;
+use Lintian::Data::Authority::DebianPolicy;
+use Lintian::Data::Authority::DeveloperReference;
+use Lintian::Data::Authority::DocBaseManual;
+use Lintian::Data::Authority::FilesystemHierarchy;
+use Lintian::Data::Authority::JavaPolicy;
+use Lintian::Data::Authority::LintianManual;
+use Lintian::Data::Authority::MenuPolicy;
+use Lintian::Data::Authority::MenuManual;
+use Lintian::Data::Authority::NewMaintainer;
+use Lintian::Data::Authority::PerlPolicy;
+use Lintian::Data::Authority::PythonPolicy;
+use Lintian::Data::Authority::VimPolicy;
+
+const my $EMPTY => q{};
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Data::Authorities - Lintian's Reference Authorities
+
+=head1 SYNOPSIS
+
+ my $data = Lintian::Data->new;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authorities handles finding, parsing and implementation of Lintian reference authorities
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item markdown_authority_reference
+
+=cut
+
+sub markdown_authority_reference {
+ my ($self, $volume, $section) = @_;
+
+ my @MARKDOWN_CAPABLE = (
+ $self->new_maintainer,$self->menu_policy,
+ $self->perl_policy,$self->python_policy,
+ $self->java_policy,$self->vim_policy,
+ $self->lintian_manual,$self->developer_reference,
+ $self->policy_manual,$self->debconf_specification,
+ $self->menu_manual,$self->doc_base_manual,
+ $self->filesystem_hierarchy_standard,
+ );
+
+ my %by_shorthand = map { $_->shorthand => $_ } @MARKDOWN_CAPABLE;
+
+ return $EMPTY
+ unless exists $by_shorthand{$volume};
+
+ my $manual = $by_shorthand{$volume};
+
+ return $manual->markdown_citation($section);
+}
+
+=item debconf_specification
+
+=cut
+
+has debconf_specification => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::DebconfSpecification->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item developer_reference
+
+=cut
+
+has developer_reference => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::DeveloperReference->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item doc_base_manual
+
+=cut
+
+has doc_base_manual => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::DocBaseManual->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item filesystem_hierarchy_standard
+
+=cut
+
+has filesystem_hierarchy_standard => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual= Lintian::Data::Authority::FilesystemHierarchy->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item java_policy
+
+=cut
+
+has java_policy => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::JavaPolicy->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item lintian_manual
+
+=cut
+
+has lintian_manual => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::LintianManual->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item menu_manual
+
+=cut
+
+has menu_manual => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::MenuManual->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item menu_policy
+
+=cut
+
+has menu_policy => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::MenuPolicy->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item menu_policy
+
+=cut
+
+has new_maintainer => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::NewMaintainer->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item perl_policy
+
+=cut
+
+has perl_policy => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::PerlPolicy->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item policy_manual
+
+=cut
+
+has policy_manual => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::DebianPolicy->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item python_policy
+
+=cut
+
+has python_policy => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::PythonPolicy->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=item vim_policy
+
+=cut
+
+has vim_policy => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $manual = Lintian::Data::Authority::VimPolicy->new;
+ $manual->load($self->data_paths, $self->vendor);
+
+ return $manual;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/DebconfSpecification.pm b/lib/Lintian/Data/Authority/DebconfSpecification.pm
new file mode 100644
index 0000000..661d11e
--- /dev/null
+++ b/lib/Lintian/Data/Authority/DebconfSpecification.pm
@@ -0,0 +1,328 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::DebconfSpecification;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use File::Basename qw(dirname);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::DebconfSpecification - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::DebconfSpecification;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::DebconfSpecification provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Debconf Specification'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'debconf-specification'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url, $page_name)= @_;
+
+ my $page_url = $base_url . $page_name;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($page_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $page_title, $page_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $relative_destination = $link->url;
+
+ my $destination_base = $page_url;
+ $destination_base = dirname($page_url) . $SLASH
+ unless $destination_base =~ m{ / $}x
+ || $relative_destination =~ m{^ [#] }x;
+
+ my $full_destination = $destination_base . $relative_destination;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq$full_destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne$full_destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $full_destination;
+
+ write_line($data_fd, $section_key, $section_title, $full_destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # single page
+ my $base_url = 'https://www.debian.org/doc/packaging-manuals/';
+ my $index_name = 'debconf_specification.html';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url, $index_name);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/DebianPolicy.pm b/lib/Lintian/Data/Authority/DebianPolicy.pm
new file mode 100644
index 0000000..177b07d
--- /dev/null
+++ b/lib/Lintian/Data/Authority/DebianPolicy.pm
@@ -0,0 +1,321 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::DebianPolicy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::DebianPolicy - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::DebianPolicy;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::DebianPolicy provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Debian Policy'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'debian-policy'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url)= @_;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $page_title, $base_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq $destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne $destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ # do not collect the upgrading checklists in appendix 10 of policy
+ # the numbering changes all the time
+ next
+ if $section_key =~ m{^ appendix-10 [.] }x;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $destination;
+
+ write_line($data_fd, $section_key, $section_title, $destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url = 'https://www.debian.org/doc/debian-policy/';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/DeveloperReference.pm b/lib/Lintian/Data/Authority/DeveloperReference.pm
new file mode 100644
index 0000000..676cbf4
--- /dev/null
+++ b/lib/Lintian/Data/Authority/DeveloperReference.pm
@@ -0,0 +1,319 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::DeveloperReference;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::DeveloperReference - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::DeveloperReference;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::DeveloperReference provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => q{Developer's Reference}
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'developer-reference'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url)= @_;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $page_title, $base_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ # developers reference likes to return locale specific pages
+ $destination =~ s{ [.]\w{2}[.]html }{.html}x;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq $destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne $destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $destination;
+
+ write_line($data_fd, $section_key, $section_title, $destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url = 'https://www.debian.org/doc/developers-reference/';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/DocBaseManual.pm b/lib/Lintian/Data/Authority/DocBaseManual.pm
new file mode 100644
index 0000000..53cfbcb
--- /dev/null
+++ b/lib/Lintian/Data/Authority/DocBaseManual.pm
@@ -0,0 +1,431 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::DocBaseManual;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use File::Basename qw(dirname basename);
+use IPC::Run3;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $INDENT => $SPACE x 4;
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::DocBaseManual - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::DocBaseManual;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::DocBaseManual provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Doc-Base Manual'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'doc-base-manual'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item find_installable_name
+
+=cut
+
+sub find_installable_name {
+ my ($self, $archive, $port, $requested_path) = @_;
+
+ my @installed_by;
+
+ # find installable package
+ for my $installable_architecture ('all', $port) {
+
+ my $local_path
+ = $archive->contents_gz('sid', 'main', $installable_architecture);
+
+ open(my $fd, '<:gzip', $local_path)
+ or die encode_utf8("Cannot open $local_path.");
+
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my ($path, $finder) = split($SPACE, $line, 2);
+ next
+ unless length $path
+ && length $finder;
+
+ if ($path eq $requested_path) {
+
+ my $name = $1;
+
+ my @locations = split(m{,}, $finder);
+ for my $location (@locations) {
+
+ my ($section, $installable)= split(m{/}, $location, 2);
+
+ push(@installed_by, $installable);
+ }
+
+ next;
+ }
+ }
+
+ close $fd;
+ }
+
+ die encode_utf8(
+ "The path $requested_path is not installed by any package.")
+ if @installed_by < 1;
+
+ if (@installed_by > 1) {
+ warn encode_utf8(
+ "The path $requested_path is installed by multiple packages:\n");
+ warn encode_utf8($INDENT . "- $_\n")for @installed_by;
+ }
+
+ my $installable_name = shift @installed_by;
+
+ return $installable_name;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # shipped as part of the doc-base installable
+ my $shipped_base = 'usr/share/doc/doc-base/doc-base.html/';
+ my $index_name = 'index.html';
+
+ my $shipped_path = $shipped_base . $index_name;
+ my $stored_uri = "file:///$shipped_path";
+
+ # neutral sort order
+ local $ENV{LC_ALL} = 'C';
+
+ my $port = 'amd64';
+ my $installable_name
+ = $self->find_installable_name($archive, $port, $shipped_path);
+
+ my $deb822_by_installable_name
+ = $archive->deb822_packages_by_installable_name('sid', 'main', $port);
+
+ my $work_folder
+ = Path::Tiny->tempdir(TEMPLATE => 'refresh-doc-base-manual-XXXXXXXXXX');
+
+ die encode_utf8("Installable $installable_name not shipped in port $port")
+ unless exists $deb822_by_installable_name->{$installable_name};
+
+ my $deb822 = $deb822_by_installable_name->{$installable_name};
+
+ my $pool_path = $deb822->value('Filename');
+
+ my $deb_filename = basename($pool_path);
+ my $deb_local_path = "$work_folder/$deb_filename";
+ my $deb_url = $archive->mirror_base . $SLASH . $pool_path;
+
+ my $stderr;
+ run3([qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url],
+ undef, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ my $extract_folder = "$work_folder/unpacked/$pool_path";
+ path($extract_folder)->mkpath;
+
+ run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder],
+ undef, \$stderr);
+ $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ unlink($deb_local_path)
+ or die encode_utf8("Cannot delete $deb_local_path");
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ my $mechanize = WWW::Mechanize->new();
+
+ my $fresh_uri = URI::file->new_abs("/$extract_folder/$shipped_path");
+ $mechanize->get($fresh_uri);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($memory_fd, $VOLUME_KEY, $page_title, $stored_uri);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $relative_destination = $link->url;
+
+ my $destination_base = $stored_uri;
+ $destination_base = dirname($stored_uri) . $SLASH
+ unless $destination_base =~ m{ / $}x
+ || $relative_destination =~ m{^ [#] }x;
+
+ my $full_destination = $destination_base . $relative_destination;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq$full_destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne$full_destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $full_destination;
+
+ write_line($memory_fd, $section_key, $section_title,$full_destination);
+ }
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/FilesystemHierarchy.pm b/lib/Lintian/Data/Authority/FilesystemHierarchy.pm
new file mode 100644
index 0000000..89fb677
--- /dev/null
+++ b/lib/Lintian/Data/Authority/FilesystemHierarchy.pm
@@ -0,0 +1,333 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::FilesystemHierarchy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use File::Basename qw(dirname);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $THREE_PARTS => 3;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::FilesystemHierarchy - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::FilesystemHierarchy;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::FilesystemHierarchy provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Filesystem Hierarchy Standard'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'filesystem-hierarchy'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($number, $title, $url)
+ = split($self->separator, $remainder, $THREE_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{number} = $number;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_number;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_number = $section_entry->{number};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_number,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_number, $section_title, $destination)
+ = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,
+ $section_key, $section_number, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url, $page_name)= @_;
+
+ my $page_url = $base_url . $page_name;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($page_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $EMPTY, $page_title, $page_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->url;
+
+ # make lowercase
+ my $section_key = lc($link->url);
+
+ # strip hash; it's a fragment;
+ $section_key =~ s{^ [#] }{}x;
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_number = $1;
+ my $section_title = $2;
+
+ # drop final dot
+ $section_number =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ # includes hash
+ my $relative_destination = $link->url;
+
+ my $destination_base = $page_url;
+ $destination_base = dirname($page_url) . $SLASH
+ unless $destination_base =~ m{ / $}x
+ || $relative_destination =~ m{^ [#] }x;
+
+ my $full_destination = $destination_base . $relative_destination;
+
+ next
+ if exists $by_section_key{$section_key};
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{number} = $section_number;
+ $by_section_key{$section_key}{destination} = $full_destination;
+
+ write_line($data_fd, $section_key, $section_number,
+ $section_title, $full_destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # single page version
+ # plain directory shows a file list
+ my $base_url = 'https://refspecs.linuxfoundation.org/FHS_3.0/';
+ my $index_name = 'fhs-3.0.html';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url, $index_name);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/JavaPolicy.pm b/lib/Lintian/Data/Authority/JavaPolicy.pm
new file mode 100644
index 0000000..eaa6704
--- /dev/null
+++ b/lib/Lintian/Data/Authority/JavaPolicy.pm
@@ -0,0 +1,290 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::JavaPolicy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use List::SomeUtils qw(any first_value);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $SLASH => q{/};
+const my $UNDERSCORE => q{_};
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SECTIONS => 'sections';
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=head1 NAME
+
+Lintian::Data::Authority::JavaPolicy - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::JavaPolicy;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::JavaPolicy provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item by_section_key
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Java Policy'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'java-policy'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand . '.json';
+ }
+);
+
+has by_section_key => (is => 'rw', default => sub { {} });
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{destination};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{destination};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item recognizes (KEY)
+
+Returns true if KEY is known, and false otherwise.
+
+=cut
+
+sub recognizes {
+ my ($self, $key) = @_;
+
+ return 0
+ unless length $key;
+
+ return 1
+ if exists $self->by_section_key->{$key};
+
+ return 0;
+}
+
+=item value (KEY)
+
+Returns the value attached to KEY if it was listed in the data
+file represented by this Lintian::Data instance and the undefined value
+otherwise.
+
+=cut
+
+sub value {
+ my ($self, $key) = @_;
+
+ return undef
+ unless length $key;
+
+ return $self->by_section_key->{$key};
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $reference;
+
+ return 0
+ unless $self->read_file($path, \$reference);
+
+ my @sections = @{$reference // []};
+
+ for my $section (@sections) {
+
+ my $key = $section->{key};
+
+ # only store first value for duplicates
+ # silently ignore later values
+ $self->by_section_key->{$key} //= $section;
+ }
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url = 'https://www.debian.org/doc/packaging-manuals/java-policy/';
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ my @sections;
+
+ # underscore is a token for the whole page
+ my %volume;
+ $volume{key} = $VOLUME_KEY;
+ $volume{title} = $page_title;
+ $volume{destination} = $base_url;
+
+ # store array to resemble web layout
+ # may contain duplicates
+ push(@sections, \%volume);
+
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ my @similar = grep { $_->{key} eq $section_key } @sections;
+ next
+ if (any { $_->{title} eq $section_title } @similar)
+ || (any { $_->{destination} eq $destination } @similar);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if any { $_->{destination} ne $destination } @similar;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ my %section;
+ $section{key} = $section_key;
+ $section{title} = $section_title;
+ $section{destination} = $destination;
+ push(@sections, \%section);
+ }
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status = $self->write_file($SECTIONS, \@sections, $data_path);
+
+ return $status;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/LintianManual.pm b/lib/Lintian/Data/Authority/LintianManual.pm
new file mode 100644
index 0000000..3fc7bd0
--- /dev/null
+++ b/lib/Lintian/Data/Authority/LintianManual.pm
@@ -0,0 +1,324 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::LintianManual;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use IPC::Run3;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use URI::file;
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::LintianManual - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::LintianManual;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::LintianManual provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Lintian Manual'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'lintian-manual'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # WWW::Mechanize will not parse page title without the suffix
+ my $temp_tiny = Path::Tiny->tempfile(
+ TEMPLATE => 'lintian-manual-XXXXXXXX',
+ SUFFIX => '.html'
+ );
+ my $local_uri = URI::file->new_abs($temp_tiny->stringify);
+
+ # for rst2html
+ local $ENV{LC_ALL} = 'en_US.UTF-8';
+
+ my $stderr;
+ run3(['rst2html', "$ENV{LINTIAN_BASE}/doc/lintian.rst"],
+ undef, $local_uri->file, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8("Cannot open scalar: $!");
+
+ my $page_url = 'https://lintian.debian.org/manual/index.html';
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($local_uri);
+
+ my $page_title = $mechanize->title;
+
+ # underscore is a token for the whole page
+ write_line($memory_fd, $VOLUME_KEY, $page_title, $page_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $page_url . $link->url;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq $destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne $destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $destination;
+
+ write_line($memory_fd, $section_key, $section_title, $destination);
+ }
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/MenuManual.pm b/lib/Lintian/Data/Authority/MenuManual.pm
new file mode 100644
index 0000000..c8a2878
--- /dev/null
+++ b/lib/Lintian/Data/Authority/MenuManual.pm
@@ -0,0 +1,316 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::MenuManual;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::MenuManual - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::MenuManual;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::MenuManual provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Menu Manual'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'menu-manual'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url)= @_;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $page_title, $base_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq $destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne $destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $destination;
+
+ write_line($data_fd, $section_key, $section_title, $destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url = 'https://www.debian.org/doc/packaging-manuals/menu.html/';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/MenuPolicy.pm b/lib/Lintian/Data/Authority/MenuPolicy.pm
new file mode 100644
index 0000000..e0f710a
--- /dev/null
+++ b/lib/Lintian/Data/Authority/MenuPolicy.pm
@@ -0,0 +1,316 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::MenuPolicy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::MenuPolicy - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::MenuPolicy;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::MenuPolicy provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Menu Policy'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'menu-policy'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url)= @_;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $page_title, $base_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq $destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne $destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $destination;
+
+ write_line($data_fd, $section_key, $section_title, $destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url = 'https://www.debian.org/doc/packaging-manuals/menu-policy/';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/NewMaintainer.pm b/lib/Lintian/Data/Authority/NewMaintainer.pm
new file mode 100644
index 0000000..bd8c933
--- /dev/null
+++ b/lib/Lintian/Data/Authority/NewMaintainer.pm
@@ -0,0 +1,290 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::NewMaintainer;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use List::SomeUtils qw(any first_value);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $SLASH => q{/};
+const my $UNDERSCORE => q{_};
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SECTIONS => 'sections';
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=head1 NAME
+
+Lintian::Data::Authority::NewMaintainer - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::NewMaintainer;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::NewMaintainer provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item by_section_key
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'New Maintainer\'s Guide'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'new-maintainer'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand . '.json';
+ }
+);
+
+has by_section_key => (is => 'rw', default => sub { {} });
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{destination};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{destination};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item recognizes (KEY)
+
+Returns true if KEY is known, and false otherwise.
+
+=cut
+
+sub recognizes {
+ my ($self, $key) = @_;
+
+ return 0
+ unless length $key;
+
+ return 1
+ if exists $self->by_section_key->{$key};
+
+ return 0;
+}
+
+=item value (KEY)
+
+Returns the value attached to KEY if it was listed in the data
+file represented by this Lintian::Data instance and the undefined value
+otherwise.
+
+=cut
+
+sub value {
+ my ($self, $key) = @_;
+
+ return undef
+ unless length $key;
+
+ return $self->by_section_key->{$key};
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $reference;
+
+ return 0
+ unless $self->read_file($path, \$reference);
+
+ my @sections = @{$reference // []};
+
+ for my $section (@sections) {
+
+ my $key = $section->{key};
+
+ # only store first value for duplicates
+ # silently ignore later values
+ $self->by_section_key->{$key} //= $section;
+ }
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url = 'https://www.debian.org/doc/manuals/maint-guide/index.html';
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ my @sections;
+
+ # underscore is a token for the whole page
+ my %volume;
+ $volume{key} = $VOLUME_KEY;
+ $volume{title} = $page_title;
+ $volume{destination} = $base_url;
+
+ # store array to resemble web layout
+ # may contain duplicates
+ push(@sections, \%volume);
+
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d[:upper:]]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ my @similar = grep { $_->{key} eq $section_key } @sections;
+ next
+ if (any { $_->{title} eq $section_title } @similar)
+ || (any { $_->{destination} eq $destination } @similar);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if any { $_->{destination} ne $destination } @similar;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ my %section;
+ $section{key} = $section_key;
+ $section{title} = $section_title;
+ $section{destination} = $destination;
+ push(@sections, \%section);
+ }
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status = $self->write_file($SECTIONS, \@sections, $data_path);
+
+ return $status;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/PerlPolicy.pm b/lib/Lintian/Data/Authority/PerlPolicy.pm
new file mode 100644
index 0000000..92dc31a
--- /dev/null
+++ b/lib/Lintian/Data/Authority/PerlPolicy.pm
@@ -0,0 +1,316 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::PerlPolicy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::PerlPolicy - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::PerlPolicy;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::PerlPolicy provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Perl Policy'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'perl-policy'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url)= @_;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $page_title, $base_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([A-Z]|[A-Z]?[.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq $destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne $destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $destination;
+
+ write_line($data_fd, $section_key, $section_title, $destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url = 'https://www.debian.org/doc/packaging-manuals/perl-policy/';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/PythonPolicy.pm b/lib/Lintian/Data/Authority/PythonPolicy.pm
new file mode 100644
index 0000000..ebeda04
--- /dev/null
+++ b/lib/Lintian/Data/Authority/PythonPolicy.pm
@@ -0,0 +1,317 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::PythonPolicy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+use WWW::Mechanize ();
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::PythonPolicy - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::PythonPolicy;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::PythonPolicy provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Python Policy'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'python-policy'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item extract_sections_from_links
+
+=cut
+
+sub extract_sections_from_links {
+ my ($self, $data_fd, $base_url)= @_;
+
+ my $mechanize = WWW::Mechanize->new();
+ $mechanize->get($base_url);
+
+ my $page_title = $mechanize->title;
+
+ # strip explanatory remark
+ $page_title =~ s{ \s* \N{EM DASH} .* $}{}x;
+
+ # underscore is a token for the whole page
+ write_line($data_fd, $VOLUME_KEY, $page_title, $base_url);
+
+ my %by_section_key;
+ my $in_appendix = 0;
+
+ # https://stackoverflow.com/a/254687
+ for my $link ($mechanize->links) {
+
+ next
+ unless length $link->text;
+
+ next
+ if $link->text !~ qr{^ \s* ([.\d]+) \s+ (.+) $}x;
+
+ my $section_key = $1;
+ my $section_title = $2;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $destination = $base_url . $link->url;
+
+ next
+ if exists $by_section_key{$section_key}
+ && ( $by_section_key{$section_key}{title} eq $section_title
+ || $by_section_key{$section_key}{destination} eq $destination);
+
+ # Some manuals reuse section numbers for different references,
+ # e.g. the Debian Policy's normal and appendix sections are
+ # numbers that clash with each other. Track if we've already
+ # seen a section pointing to some other URL than the current one,
+ # and prepend it with an indicator
+ $in_appendix = 1
+ if exists $by_section_key{$section_key}
+ && $by_section_key{$section_key}{destination} ne $destination;
+
+ $section_key = "appendix-$section_key"
+ if $in_appendix;
+
+ $by_section_key{$section_key}{title} = $section_title;
+ $by_section_key{$section_key}{destination} = $destination;
+
+ write_line($data_fd, $section_key, $section_title, $destination);
+ }
+
+ return;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $base_url
+ = 'https://www.debian.org/doc/packaging-manuals/python-policy/';
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8('Cannot open scalar');
+
+ $self->extract_sections_from_links($memory_fd, $base_url);
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Authority/VimPolicy.pm b/lib/Lintian/Data/Authority/VimPolicy.pm
new file mode 100644
index 0000000..6ffbe91
--- /dev/null
+++ b/lib/Lintian/Data/Authority/VimPolicy.pm
@@ -0,0 +1,459 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2001 Colin Watson
+# Copyright (C) 2008 Jorda Polo
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Authority::VimPolicy;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use File::Basename qw(basename);
+use IPC::Run3;
+use HTML::TokeParser::Simple;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Output::Markdown qw(markdown_authority);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $COLON => q{:};
+const my $INDENT => $SPACE x 4;
+const my $UNDERSCORE => q{_};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+const my $TWO_PARTS => 2;
+
+const my $VOLUME_KEY => $UNDERSCORE;
+const my $SEPARATOR => $COLON x 2;
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Authority::VimPolicy - Lintian interface for manual references
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Authority::VimPolicy;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Authority::VimPolicy provides a way to load data files for
+manual references.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item title
+
+=item shorthand
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Vim Policy'
+);
+
+has shorthand => (
+ is => 'rw',
+ default => 'vim-policy'
+);
+
+has location => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 'authority/' . $self->shorthand;
+ }
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/::/ }
+);
+
+=item consumer
+
+=cut
+
+sub consumer {
+ my ($self, $key, $remainder, $previous) = @_;
+
+ return undef
+ if defined $previous;
+
+ my ($title, $url)= split($self->separator, $remainder, $TWO_PARTS);
+
+ my %entry;
+ $entry{title} = $title;
+ $entry{url} = $url;
+
+ return \%entry;
+}
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($self, $section_key) = @_;
+
+ croak "Invalid section $section_key"
+ if $section_key eq $VOLUME_KEY;
+
+ my $volume_entry = $self->value($VOLUME_KEY);
+
+ # start with the citation to the overall manual.
+ my $volume_title = $volume_entry->{title};
+ my $volume_url = $volume_entry->{url};
+
+ my $section_title;
+ my $section_url;
+
+ if ($self->recognizes($section_key)) {
+
+ my $section_entry = $self->value($section_key);
+
+ $section_title = $section_entry->{title};
+ $section_url = $section_entry->{url};
+ }
+
+ return markdown_authority(
+ $volume_title, $volume_url,$section_key,
+ $section_title, $section_url
+ );
+}
+
+=item write_line
+
+=cut
+
+sub write_line {
+ my ($data_fd, $section_key, $section_title, $destination) = @_;
+
+ # drop final dots
+ $section_key =~ s{ [.]+ $}{}x;
+
+ # reduce consecutive whitespace
+ $section_title =~ s{ \s+ }{ }gx;
+
+ my $line= join($SEPARATOR,$section_key, $section_title, $destination);
+
+ say {$data_fd} encode_utf8($line);
+
+ return;
+}
+
+=item write_data_file
+
+=cut
+
+sub write_data_file {
+ my ($self, $basedir, $generated) = @_;
+
+ my $header =<<"HEADER";
+# Data about titles, sections, and URLs of manuals, used to expand references
+# in tag descriptions and add links for HTML output. Each line of this file
+# has three fields separated by double colons:
+#
+# <section> :: <title> :: <url>
+#
+# If <section> is an underscore, that line specifies the title and URL for the
+# whole manual.
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return;
+}
+
+=item find_installable_name
+
+=cut
+
+sub find_installable_name {
+ my ($self, $archive, $release, $liberty, $port, $requested_path) = @_;
+
+ my @installed_by;
+
+ # find installable package
+ for my $installable_architecture ('all', $port) {
+
+ my $local_path
+ = $archive->contents_gz($release, $liberty,
+ $installable_architecture);
+
+ open(my $fd, '<:gzip', $local_path)
+ or die encode_utf8("Cannot open $local_path.");
+
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my ($path, $finder) = split($SPACE, $line, 2);
+ next
+ unless length $path
+ && length $finder;
+
+ if ($path eq $requested_path) {
+
+ my $name = $1;
+
+ my @locations = split(m{,}, $finder);
+ for my $location (@locations) {
+
+ my ($section, $installable)= split(m{/}, $location, 2);
+
+ push(@installed_by, $installable);
+ }
+
+ next;
+ }
+ }
+
+ close $fd;
+ }
+
+ die encode_utf8(
+ "The path $requested_path is not installed by any package.")
+ if @installed_by < 1;
+
+ if (@installed_by > 1) {
+ warn encode_utf8(
+ "The path $requested_path is installed by multiple packages:\n");
+ warn encode_utf8($INDENT . "- $_\n")for @installed_by;
+ }
+
+ my $installable_name = shift @installed_by;
+
+ return $installable_name;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # shipped as part of the vim installable
+ my $shipped_base = 'usr/share/doc/vim/vim-policy.html/';
+ my $index_name = 'index.html';
+
+ my $shipped_path = $shipped_base . $index_name;
+ my $stored_uri = "file:///$shipped_base";
+
+ # neutral sort order
+ local $ENV{LC_ALL} = 'C';
+
+ my $release = 'stable';
+ my $port = 'amd64';
+
+ my $installable_name
+ = $self->find_installable_name($archive, $release, 'main', $port,
+ $shipped_path);
+
+ my $deb822_by_installable_name
+ = $archive->deb822_packages_by_installable_name($release, 'main', $port);
+
+ my $work_folder
+ = Path::Tiny->tempdir(
+ TEMPLATE => 'refresh-doc-base-specification-XXXXXXXXXX');
+
+ die encode_utf8("Installable $installable_name not shipped in port $port")
+ unless exists $deb822_by_installable_name->{$installable_name};
+
+ my $deb822 = $deb822_by_installable_name->{$installable_name};
+
+ my $pool_path = $deb822->value('Filename');
+
+ my $deb_filename = basename($pool_path);
+ my $deb_local_path = "$work_folder/$deb_filename";
+ my $deb_url = $archive->mirror_base . $SLASH . $pool_path;
+
+ my $stderr;
+ run3([qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url],
+ undef, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ my $extract_folder = "$work_folder/unpacked/$pool_path";
+ path($extract_folder)->mkpath;
+
+ run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder],
+ undef, \$stderr);
+ $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ unlink($deb_local_path)
+ or die encode_utf8("Cannot delete $deb_local_path");
+
+ my $generated;
+ open(my $memory_fd, '>', \$generated)
+ or die encode_utf8("Cannot open scalar: $!");
+
+ my $fresh_uri = URI::file->new_abs("/$extract_folder/$shipped_path");
+
+ my $parser = HTML::TokeParser::Simple->new(url => $fresh_uri);
+ my $in_title = 0;
+ my $in_dt_tag = 0;
+ my $after_a_tag = 0;
+
+ my $page_title = $EMPTY;
+ my $section_key = $EMPTY;
+ my $section_title = $EMPTY;
+ my $relative_destination = $EMPTY;
+
+ while (my $token = $parser->get_token) {
+
+ if (length $token->get_tag) {
+
+ if ($token->get_tag eq 'h1') {
+
+ $in_title = ($token->is_start_tag
+ && $token->get_attr('class') eq 'title');
+
+ # not yet leaving title
+ next
+ if $in_title;
+
+ # trim both ends
+ $page_title =~ s/^\s+|\s+$//g;
+
+ # underscore is a token for the whole page
+ write_line($memory_fd, $VOLUME_KEY, $page_title,
+ $stored_uri . $index_name)
+ if length $page_title;
+
+ $page_title = $EMPTY;
+ }
+
+ if ($token->get_tag eq 'dt') {
+
+ $in_dt_tag = $token->is_start_tag;
+
+ # not yet leaving dt tag
+ next
+ if $in_dt_tag;
+
+ # trim both ends
+ $section_key =~ s/^\s+|\s+$//g;
+ $section_title =~ s/^\s+|\s+$//g;
+
+ my $full_destination = $stored_uri . $relative_destination;
+
+ write_line(
+ $memory_fd, $section_key,
+ $section_title,$full_destination
+ )if length $section_title;
+
+ $section_key = $EMPTY;
+ $section_title = $EMPTY;
+ $relative_destination = $EMPTY;
+ }
+
+ if ($token->get_tag eq 'a') {
+
+ $after_a_tag = $token->is_start_tag;
+
+ $relative_destination = $token->get_attr('href')
+ if $token->is_start_tag;
+ }
+
+ } else {
+
+ # concatenate span objects
+ $page_title .= $token->as_is
+ if length $token->as_is
+ && $in_title
+ && $after_a_tag;
+
+ $section_key = $token->as_is
+ if length $token->as_is
+ && $in_dt_tag
+ && !$after_a_tag;
+
+ # concatenate span objects
+ $section_title .= $token->as_is
+ if length $token->as_is
+ && $in_dt_tag
+ && $after_a_tag;
+ }
+ }
+
+ close $memory_fd;
+
+ $self->write_data_file($basedir, $generated);
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Buildflags/Hardening.pm b/lib/Lintian/Data/Buildflags/Hardening.pm
new file mode 100644
index 0000000..75056df
--- /dev/null
+++ b/lib/Lintian/Data/Buildflags/Hardening.pm
@@ -0,0 +1,154 @@
+# -*- perl -*-
+
+# Copyright (C) 2011-2012 Niels Thykier <niels@thykier.net>
+# - Based on a shell script by Raphael Geissert <atomo64@gmail.com>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Buildflags::Hardening;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(first_value uniq);
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::Deb822;
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+const my $RECOMMENDED_FEATURES => q{recommended_features};
+
+with 'Lintian::Data::PreambledJSON';
+
+=encoding utf-8
+
+=head1 NAME
+
+Lintian::Data::Buildflags::Hardening -- Lintian API for hardening build flags
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Buildflags::Hardening;
+
+=head1 DESCRIPTION
+
+Lintian API for hardening build flags.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item recommended_features
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Hardening Flags from Dpkg'
+);
+
+has location => (
+ is => 'rw',
+ default => 'buildflags/hardening.json'
+);
+
+has recommended_features => (
+ is => 'rw',
+ default => sub { {} },
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); }
+);
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $recommended_features;
+ return 0
+ unless $self->read_file($path, \$recommended_features);
+
+ $self->recommended_features($recommended_features);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # find all recommended hardening features
+ local $ENV{LC_ALL} = 'C';
+ local $ENV{DEB_BUILD_MAINT_OPTIONS} = 'hardening=+all';
+
+ my @architectures
+ = split(/\n/, decode_utf8(safe_qx('dpkg-architecture', '-L')));
+ chomp for @architectures;
+
+ my %recommended_features;
+ for my $architecture (@architectures) {
+
+ local $ENV{DEB_HOST_ARCH} = $architecture;
+
+ my @command = qw{dpkg-buildflags --query-features hardening};
+ my $feature_output = decode_utf8(safe_qx(@command));
+
+ my $deb822 = Lintian::Deb822->new;
+ my @sections = $deb822->parse_string($feature_output);
+
+ my @enabled = grep { $_->value('Enabled') eq 'yes' } @sections;
+ my @features = uniq map { $_->value('Feature') } @enabled;
+
+ $recommended_features{$architecture} = [sort @features];
+ }
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status
+ = $self->write_file($RECOMMENDED_FEATURES, \%recommended_features,
+ $data_path);
+
+ return $status;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Debhelper/Addons.pm b/lib/Lintian/Data/Debhelper/Addons.pm
new file mode 100644
index 0000000..3b8dbb1
--- /dev/null
+++ b/lib/Lintian/Data/Debhelper/Addons.pm
@@ -0,0 +1,215 @@
+# -*- perl -*-
+#
+# Copyright (C) 2008 by Raphael Geissert <atomo64@gmail.com>
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Debhelper::Addons;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use List::SomeUtils qw(first_value any uniq);
+use PerlIO::gzip;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+const my $ADD_ONS => 'add_ons';
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=head1 NAME
+
+Lintian::Data::Debhelper::Addons - Lintian interface for debhelper addons.
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Debhelper::Addons;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for debhelper.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item installable_names_by_add_on
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Debhelper Add-ons'
+);
+
+has location => (
+ is => 'rw',
+ default => 'debhelper/add_ons.json'
+);
+
+has installable_names_by_add_on => (is => 'rw', default => sub { {} });
+
+=item all
+
+=cut
+
+sub all {
+ my ($self) = @_;
+
+ return keys %{$self->installable_names_by_add_on};
+}
+
+=item installed_by
+
+=cut
+
+sub installed_by {
+ my ($self, $name) = @_;
+
+ return ()
+ unless exists $self->installable_names_by_add_on->{$name};
+
+ my @installed_by = @{$self->installable_names_by_add_on->{$name} // []};
+
+ push(@installed_by, 'debhelper-compat')
+ if any { $_ eq 'debhelper' } @installed_by;
+
+ return @installed_by;
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $reference;
+ return 0
+ unless $self->read_file($path, \$reference);
+
+ my %add_ons = %{$reference // {}};
+ my %installable_names_by_add_on;
+
+ for my $name (keys %add_ons) {
+
+ my @installable_names;
+ push(@installable_names, @{$add_ons{$name}{installed_by}});
+
+ $installable_names_by_add_on{$name} = \@installable_names;
+ }
+
+ $self->installable_names_by_add_on(\%installable_names_by_add_on);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # neutral sort order
+ local $ENV{LC_ALL} = 'C';
+
+ my $port = 'amd64';
+
+ my %add_ons;
+
+ for my $installable_architecture ('all', $port) {
+
+ my $local_path
+ = $archive->contents_gz('sid', 'main', $installable_architecture);
+
+ open(my $fd, '<:gzip', $local_path)
+ or die encode_utf8("Cannot open $local_path.");
+
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my ($path, $finder) = split($SPACE, $line, 2);
+ next
+ unless length $path
+ && length $finder;
+
+ if ($path
+ =~ m{^ usr/share/perl5/Debian/Debhelper/Sequence/ (\S+) [.]pm $}x
+ ) {
+
+ my $name = $1;
+
+ my @locations = split(m{,}, $finder);
+ for my $location (@locations) {
+
+ my ($section, $installable)= split(m{/}, $location, 2);
+
+ $add_ons{$name}{installed_by} //= [];
+ push(@{$add_ons{$name}{installed_by}}, $installable);
+ }
+
+ next;
+ }
+ }
+
+ close $fd;
+ }
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status = $self->write_file($ADD_ONS, \%add_ons,$data_path);
+
+ return $status;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Debhelper/Commands.pm b/lib/Lintian/Data/Debhelper/Commands.pm
new file mode 100644
index 0000000..bd1ea67
--- /dev/null
+++ b/lib/Lintian/Data/Debhelper/Commands.pm
@@ -0,0 +1,306 @@
+# -*- perl -*-
+#
+# Copyright (C) 2008 by Raphael Geissert <atomo64@gmail.com>
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Debhelper::Commands;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use IPC::Run3;
+use List::SomeUtils qw(first_value any uniq);
+use Path::Tiny;
+use PerlIO::gzip;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+const my $COMMANDS => 'commands';
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=head1 NAME
+
+Lintian::Data::Debhelper::Commands - Lintian interface for debhelper commands.
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Debhelper::Commands;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for debhelper.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item installable_names_by_command
+
+=item maint_commands
+
+=item misc_depends_commands
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Debhelper Commands'
+);
+
+has location => (
+ is => 'rw',
+ default => 'debhelper/commands.json'
+);
+
+has installable_names_by_command => (is => 'rw', default => sub { {} });
+has maint_commands => (is => 'rw', default => sub { [] });
+has misc_depends_commands => (is => 'rw', default => sub { [] });
+
+=item all
+
+=cut
+
+sub all {
+ my ($self) = @_;
+
+ return keys %{$self->installable_names_by_command};
+}
+
+=item installed_by
+
+=cut
+
+sub installed_by {
+ my ($self, $name) = @_;
+
+ return ()
+ unless exists $self->installable_names_by_command->{$name};
+
+ my @installed_by = @{$self->installable_names_by_command->{$name} // []};
+
+ push(@installed_by, 'debhelper-compat')
+ if any { $_ eq 'debhelper' } @installed_by;
+
+ return @installed_by;
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $reference;
+ return 0
+ unless $self->read_file($path, \$reference);
+
+ my %commands = %{$reference // {}};
+
+ my %installable_names_by_command;
+ my @maint_commands;
+ my @misc_depends_commands;
+
+ for my $name (keys %commands) {
+
+ my @installable_names;
+ push(@installable_names, @{$commands{$name}{installed_by}});
+
+ $installable_names_by_command{$name} = \@installable_names;
+
+ push(@maint_commands, $name)
+ if $commands{$name}{uses_autoscript};
+
+ push(@misc_depends_commands, $name)
+ if $commands{$name}{uses_misc_depends}
+ && $name ne 'dh_gencontrol';
+ }
+
+ $self->installable_names_by_command(\%installable_names_by_command);
+ $self->maint_commands(\@maint_commands);
+ $self->misc_depends_commands(\@misc_depends_commands);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # neutral sort order
+ local $ENV{LC_ALL} = 'C';
+
+ my $port = 'amd64';
+
+ my %commands;
+
+ for my $installable_architecture ('all', $port) {
+
+ my $local_path
+ = $archive->contents_gz('sid', 'main', $installable_architecture);
+
+ open(my $fd, '<:gzip', $local_path)
+ or die encode_utf8("Cannot open $local_path.");
+
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my ($path, $finder) = split($SPACE, $line, 2);
+ next
+ unless length $path
+ && length $finder;
+
+ if ($path =~ m{^ usr/bin/ (dh_ \S+) $}x) {
+
+ my $name = $1;
+
+ my @locations = split(m{,}, $finder);
+ for my $location (@locations) {
+
+ my ($section, $installable)= split(m{/}, $location, 2);
+
+ $commands{$name}{installed_by} //= [];
+ push(@{$commands{$name}{installed_by}}, $installable);
+ }
+
+ next;
+ }
+ }
+
+ close $fd;
+ }
+
+ my $deb822_by_installable_name
+ = $archive->deb822_packages_by_installable_name('sid', 'main', $port);
+
+ my $work_folder
+ = Path::Tiny->tempdir(
+ TEMPLATE => 'refresh-debhelper-add-ons-XXXXXXXXXX');
+
+ my @uses_autoscript;
+ my @uses_misc_depends;
+
+ my @installable_names= uniq map { @{$_->{installed_by}} }values %commands;
+
+ for my $installable_name (sort @installable_names) {
+
+ next
+ unless exists $deb822_by_installable_name->{$installable_name};
+
+ my $deb822 = $deb822_by_installable_name->{$installable_name};
+
+ my $pool_path = $deb822->value('Filename');
+
+ my $deb_filename = basename($pool_path);
+ my $deb_local_path = "$work_folder/$deb_filename";
+ my $deb_url = $archive->mirror_base . $SLASH . $pool_path;
+
+ my $stderr;
+ run3(
+ [qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url],
+ undef, \$stderr
+ );
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ my $extract_folder = "$work_folder/pool/$pool_path";
+ path($extract_folder)->mkpath;
+
+ run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder],
+ undef, \$stderr);
+ $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ unlink($deb_local_path)
+ or die encode_utf8("Cannot delete $deb_local_path");
+
+ my $autoscript_rule = File::Find::Rule->file;
+ $autoscript_rule->name(qr{^dh_});
+ $autoscript_rule->grep(qr{autoscript});
+ my @autoscript_matches
+ = $autoscript_rule->in("$extract_folder/usr/bin");
+
+ push(@uses_autoscript, map { basename($_) } @autoscript_matches);
+
+ my $misc_depends_rule = File::Find::Rule->file;
+ $misc_depends_rule->name(qr{^dh_});
+ $misc_depends_rule->grep(qr{misc:Depends});
+ my @misc_depends_matches
+ = $misc_depends_rule->in("$extract_folder/usr/bin");
+
+ push(@uses_misc_depends, map { basename($_) } @misc_depends_matches);
+
+ path("$work_folder/pool")->remove_tree;
+ }
+
+ $commands{$_}{uses_autoscript} = 1 for @uses_autoscript;
+
+ $commands{$_}{uses_misc_depends} = 1 for @uses_misc_depends;
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status = $self->write_file($COMMANDS, \%commands,$data_path);
+
+ return $status;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Debhelper/Levels.pm b/lib/Lintian/Data/Debhelper/Levels.pm
new file mode 100644
index 0000000..571ce2c
--- /dev/null
+++ b/lib/Lintian/Data/Debhelper/Levels.pm
@@ -0,0 +1,89 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Debhelper::Levels;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Debhelper::Levels - Lintian interface for debhelper
+compat levels.
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Debhelper::Levels;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for debhelper.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Debhelper Levels'
+);
+
+has location => (
+ is => 'rw',
+ default => 'debhelper/compat-level'
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr/=/ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Fonts.pm b/lib/Lintian/Data/Fonts.pm
new file mode 100644
index 0000000..4820439
--- /dev/null
+++ b/lib/Lintian/Data/Fonts.pm
@@ -0,0 +1,216 @@
+# -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Fonts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use List::SomeUtils qw(first_value uniq);
+use PerlIO::gzip;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+const my $FONTS => 'fonts';
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=head1 NAME
+
+Lintian::Data::Fonts - Lintian interface for fonts.
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Fonts;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for fonts.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item installable_names_by_font
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Fonts Available for Installation'
+);
+
+has location => (
+ is => 'rw',
+ default => 'fonts.json'
+);
+
+has installable_names_by_font => (is => 'rw', default => sub { {} });
+
+=item all
+
+=cut
+
+sub all {
+ my ($self) = @_;
+
+ return keys %{$self->installable_names_by_font};
+}
+
+=item installed_by
+
+=cut
+
+sub installed_by {
+ my ($self, $name) = @_;
+
+ my $lowercase = lc $name;
+
+ return ()
+ unless exists $self->installable_names_by_font->{$lowercase};
+
+ my @installed_by = @{$self->installable_names_by_font->{$lowercase} // []};
+
+ return @installed_by;
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $reference;
+ return 0
+ unless $self->read_file($path, \$reference);
+
+ my %fonts = %{$reference // {}};
+ my %installable_names_by_font;
+
+ for my $name (keys %fonts) {
+
+ my @installable_names;
+ push(@installable_names, @{$fonts{$name}{installed_by}});
+
+ $installable_names_by_font{$name} = \@installable_names;
+ }
+
+ $self->installable_names_by_font(\%installable_names_by_font);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # neutral sort order
+ local $ENV{LC_ALL} = 'C';
+
+ my $port = 'amd64';
+
+ my %fonts;
+
+ for my $installable_architecture ('all', $port) {
+
+ my $local_path
+ = $archive->contents_gz('sid', 'main', $installable_architecture);
+
+ open(my $fd, '<:gzip', $local_path)
+ or die encode_utf8("Cannot open $local_path.");
+
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my ($path, $finder) = split($SPACE, $line, 2);
+ next
+ unless length $path
+ && length $finder;
+
+ if ($path =~ m{ [.] (?:[to]tf|pfb) $}ix) {
+
+ my @locations = split(m{,}, $finder);
+ for my $location (@locations) {
+
+ my ($section, $installable_name)
+ = split(m{/}, $location, 2);
+
+ # Record only packages starting with ttf-, otf-, t1-, xfonts- or fonts-
+ next
+ unless $installable_name
+ =~ m{^ (?: [to]tf | t1 | x?fonts ) - }x;
+
+ my $basename = basename($path);
+ my $lowercase = lc $basename;
+
+ $fonts{$lowercase}{installed_by} //= [];
+ push(@{$fonts{$lowercase}{installed_by}},
+ $installable_name);
+ }
+
+ next;
+ }
+ }
+
+ close $fd;
+ }
+
+ my $data_path = "$basedir/" . $self->location;
+ my $status = $self->write_file($FONTS, \%fonts,$data_path);
+
+ return $status;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/InitD/VirtualFacilities.pm b/lib/Lintian/Data/InitD/VirtualFacilities.pm
new file mode 100644
index 0000000..fbb4030
--- /dev/null
+++ b/lib/Lintian/Data/InitD/VirtualFacilities.pm
@@ -0,0 +1,256 @@
+# -*- perl -*-
+#
+# Copyright (C) 2008, 2010 by Raphael Geissert <atomo64@gmail.com>
+# Copyright (C) 2017 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::InitD::VirtualFacilities;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use File::Basename;
+use IPC::Run3;
+use List::SomeUtils qw(first_value uniq);
+use Path::Tiny;
+use PerlIO::gzip;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $DOLLAR => q{$};
+
+const my $NEWLINE => qq{\n};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::InitD::VirtualFacilities - Lintian interface for init.d virtual facilities
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::InitD::VirtualFacilities;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for init.d.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item separator
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Init.d Virtual Facilities'
+);
+
+has location => (
+ is => 'rw',
+ default => 'init.d/virtual_facilities'
+);
+
+has separator => (
+ is => 'rw',
+ default => sub { qr{ \s+ }x }
+);
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ # neutral sort order
+ local $ENV{LC_ALL} = 'C';
+
+ my $port = 'amd64';
+
+ my %paths_by_installable_names;
+
+ for my $installable_architecture ('all', $port) {
+
+ my $local_path
+ = $archive->contents_gz('sid', 'main', $installable_architecture);
+
+ open(my $fd, '<:gzip', $local_path)
+ or die encode_utf8("Cannot open $local_path.");
+
+ while (my $line = <$fd>) {
+
+ chomp $line;
+
+ my ($path, $finder) = split($SPACE, $line, 2);
+ next
+ unless length $path
+ && length $finder;
+
+ # catch both monolithic and split configurations
+ if ($path =~ m{^ etc/insserv[.]conf (?: $ | [.]d / )? }x) {
+
+ my @locations = split(m{,}, $finder);
+ for my $location (@locations) {
+
+ my ($section, $installable)= split(m{/}, $location, 2);
+
+ $paths_by_installable_names{$installable} //= [];
+ push(@{$paths_by_installable_names{$installable}}, $path);
+ }
+
+ next;
+ }
+ }
+
+ close $fd;
+ }
+
+ my $deb822_by_installable_name
+ = $archive->deb822_packages_by_installable_name('sid', 'main', $port);
+
+ my $work_folder
+ = Path::Tiny->tempdir(
+ TEMPLATE => 'refresh-debhelper-add-ons-XXXXXXXXXX');
+
+ my @virtual_facilities;
+
+ my @installable_names = keys %paths_by_installable_names;
+
+ for my $installable_name (sort @installable_names) {
+
+ next
+ unless exists $deb822_by_installable_name->{$installable_name};
+
+ my $deb822 = $deb822_by_installable_name->{$installable_name};
+
+ my $pool_path = $deb822->value('Filename');
+
+ my $deb_filename = basename($pool_path);
+ my $deb_local_path = "$work_folder/$deb_filename";
+ my $deb_url = $archive->mirror_base . $SLASH . $pool_path;
+
+ my $stderr;
+ run3(
+ [qw{wget --quiet}, "--output-document=$deb_local_path", $deb_url],
+ undef, \$stderr
+ );
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ my $extract_folder = "$work_folder/pool/$pool_path";
+ path($extract_folder)->mkpath;
+
+ run3([qw{dpkg-deb --extract}, $deb_local_path, $extract_folder],
+ undef, \$stderr);
+ $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # stderr already in UTF-8
+ die $stderr
+ if $status;
+
+ unlink($deb_local_path)
+ or die encode_utf8("Cannot delete $deb_local_path");
+
+ my $monolithic_rule = File::Find::Rule->file;
+ $monolithic_rule->name('insserv.conf');
+ my @files= $monolithic_rule->in("$extract_folder/etc");
+
+ my $split_files_rule = File::Find::Rule->file;
+ push(@files,
+ $split_files_rule->in("$extract_folder/etc/insserv.conf.d"));
+
+ for my $path (@files) {
+
+ open(my $fd, '<', $path)
+ or die encode_utf8("Cannot open $path.");
+
+ while (my $line = <$fd>) {
+
+ if ($line =~ m{^ ( \$\S+ ) }x) {
+
+ my $virtual = $1;
+ push(@virtual_facilities, $virtual);
+ }
+ }
+
+ close $fd;
+ }
+
+ path("$work_folder/pool")->remove_tree;
+ }
+
+ push(@virtual_facilities, $DOLLAR . 'all');
+
+ my $generated = $EMPTY;
+
+ # still in UTF-8
+ $generated .= $_ . $NEWLINE for sort +uniq @virtual_facilities;
+
+ my $header =<<"HEADER";
+# The list of known virtual facilities that init scripts may depend on.
+#
+
+HEADER
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ my $output = encode_utf8($header) . $generated;
+ path($data_path)->spew($output);
+
+ return 1;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/JoinedLines.pm b/lib/Lintian/Data/JoinedLines.pm
new file mode 100644
index 0000000..a753430
--- /dev/null
+++ b/lib/Lintian/Data/JoinedLines.pm
@@ -0,0 +1,369 @@
+# -*- perl -*-
+# Lintian::Data::JoinedLines -- interface to query lists of keywords
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::JoinedLines;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(carp croak);
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+=head1 NAME
+
+Lintian::Data::JoinedLines - Lintian interface to query lists of keywords
+
+=head1 SYNOPSIS
+
+ my $keyword;
+ my $list = Lintian::Data::JoinedLines->new('type');
+ if ($list->recognizes($keyword)) {
+ # do something ...
+ }
+ my $hash = Lintian::Data::JoinedLines->new('another-type', qr{\s++});
+ if ($hash->value($keyword) > 1) {
+ # do something ...
+ }
+ if ($list->value($keyword) > 1) {
+ # do something ...
+ }
+ my @keywords = $list->all;
+ if ($list->matches_any($keyword)) {
+ # do something ...
+ }
+
+=head1 DESCRIPTION
+
+Lintian::Data::JoinedLines provides a way of loading a list of keywords or key/value
+pairs from a file in the Lintian root and then querying that list.
+The lists are stored in the F<data> directory of the Lintian root and
+consist of one keyword or key/value pair per line. Blank lines and
+lines beginning with C<#> are ignored. Leading and trailing whitespace
+is stripped.
+
+If requested, the lines are split into key/value pairs with a given
+separator regular expression. Otherwise, keywords are taken verbatim
+as they are listed in the file and may include spaces.
+
+This module allows lists such as menu sections, doc-base sections,
+obsolete packages, package fields, and so forth to be stored in simple,
+easily editable files.
+
+NB: By default Lintian::Data::JoinedLines is lazy and defers loading of the data
+file until it is actually needed.
+
+=head2 Interface for the CODE argument
+
+This section describes the interface between for the CODE argument
+for the class method new.
+
+The sub will be called once for each key/pair with three arguments,
+KEY, VALUE and CURVALUE. The first two are the key/value pair parsed
+from the data file and CURVALUE is current value associated with the
+key. CURVALUE will be C<undef> the first time the sub is called with
+that KEY argument.
+
+The sub can then modify VALUE in some way and return the new value for
+that KEY. If CURVALUE is not C<undef>, the sub may return C<undef> to
+indicate that the current value should still be used. It is not
+permissible for the sub to return C<undef> if CURVALUE is C<undef>.
+
+Where Perl semantics allow it, the sub can modify CURVALUE and the
+changes will be reflected in the result. As an example, if CURVALUE
+is a hashref, new keys can be inserted etc.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item dataset
+
+=item C<keyorder>
+
+=cut
+
+has dataset => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has keyorder => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+=item all
+
+Returns all keywords listed in the data file as a list in original order.
+In a scalar context, returns the number of keywords.
+
+=cut
+
+sub all {
+ my ($self) = @_;
+
+ return @{$self->keyorder};
+}
+
+=item recognizes (KEY)
+
+Returns true if KEY was listed in the data file represented by this
+Lintian::Data::JoinedLines instance and false otherwise.
+
+=cut
+
+sub recognizes {
+ my ($self, $key) = @_;
+
+ return 0
+ unless length $key;
+
+ return 1
+ if exists $self->dataset->{$key};
+
+ return 0;
+}
+
+=item resembles (KEY)
+
+Returns true if the data file contains a key that is a case-insensitive match
+to KEY, and false otherwise.
+
+=cut
+
+sub resembles {
+ my ($self, $key) = @_;
+
+ return 0
+ unless length $key;
+
+ return 1
+ if $self->recognizes($key);
+
+ return 1
+ if any { m{^\Q$key\E$}i } keys %{$self->dataset};
+
+ return 0;
+}
+
+=item value (KEY)
+
+Returns the value attached to KEY if it was listed in the data
+file represented by this Lintian::Data::JoinedLines instance and the undefined value
+otherwise.
+
+=cut
+
+sub value {
+ my ($self, $key) = @_;
+
+ return undef
+ unless length $key;
+
+ return $self->dataset->{$key};
+}
+
+=item matches_any(KEYWORD[, MODIFIERS])
+
+Returns true if KEYWORD matches any regular expression listed in the
+data file. The optional MODIFIERS serve as modifiers on all regexes.
+
+=cut
+
+sub matches_any {
+ my ($self, $wanted, $modifiers) = @_;
+
+ return 0
+ unless length $wanted;
+
+ $modifiers //= $EMPTY;
+
+ return 1
+ if any { $wanted =~ /(?$modifiers)$_/ } $self->all;
+
+ return 0;
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @remaining_lineage = @{$search_space // []};
+ unless (@remaining_lineage) {
+
+ carp encode_utf8('Unknown data file: ' . $self->location);
+ return 0;
+ }
+
+ my $directory = shift @remaining_lineage;
+
+ my $path = $directory . $SLASH . $self->location;
+
+ return $self->load(\@remaining_lineage, $our_vendor)
+ unless -e $path;
+
+ open(my $fd, '<:utf8_strict', $path)
+ or die encode_utf8("Cannot open $path: $!");
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # trim both ends
+ $line =~ s/^\s+|\s+$//g;
+
+ next
+ unless length $line;
+
+ next
+ if $line =~ m{^\#};
+
+ # a command
+ if ($line =~ s/^\@//) {
+
+ my ($directive, $value) = split(/\s+/, $line, 2);
+ if ($directive eq 'delete') {
+
+ croak encode_utf8(
+ "Missing key after \@delete in $path at line $position")
+ unless length $value;
+
+ @{$self->keyorder} = grep { $_ ne $value } @{$self->keyorder};
+ delete $self->dataset->{$value};
+
+ } elsif ($directive eq 'include-parent') {
+
+ $self->load(\@remaining_lineage, $our_vendor)
+ or croak encode_utf8("No ancestor data file for $path");
+
+ } elsif ($directive eq 'if-vendor-is'
+ || $directive eq 'if-vendor-is-not') {
+
+ my ($specified_vendor, $remain) = split(/\s+/, $value, 2);
+
+ croak encode_utf8("Missing vendor name after \@$directive")
+ unless length $specified_vendor;
+ croak encode_utf8(
+ "Missing command after vendor name for \@$directive")
+ unless length $remain;
+
+ $our_vendor =~ s{/.*$}{};
+
+ next
+ if $directive eq 'if-vendor-is'
+ && $our_vendor ne $specified_vendor;
+
+ next
+ if $directive eq 'if-vendor-is-not'
+ && $our_vendor eq $specified_vendor;
+
+ $line = $remain;
+ redo;
+
+ } else {
+ croak encode_utf8(
+ "Unknown operation \@$directive in $path at line $position"
+ );
+ }
+ next;
+ }
+
+ my $key = $line;
+ my $remainder;
+
+ ($key, $remainder) = split($self->separator, $line, 2)
+ if defined $self->separator;
+
+ # do not autovivify; 'exists' below
+ my $previous;
+ $previous = $self->dataset->{$key}
+ if exists $self->dataset->{$key};
+
+ my $value;
+ if ($self->can('consumer')) {
+
+ $value = $self->consumer($key, $remainder, $previous);
+ next
+ unless defined $value;
+
+ } else {
+ $value = $remainder;
+ }
+
+ push(@{$self->keyorder}, $key)
+ unless exists $self->dataset->{$key};
+
+ $self->dataset->{$key} = $value;
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return 1;
+}
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item LINTIAN_INCLUDE_DIR/data
+
+The files loaded by this module must be located in this directory.
+Relative paths containing a C</> are permitted, so files may be organized
+in subdirectories in this directory.
+
+Note that lintian supports multiple LINTIAN_INCLUDE_DIRs.
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1), L<https://lintian.debian.org/manual/section-2.6.html>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Policy/Releases.pm b/lib/Lintian/Data/Policy/Releases.pm
new file mode 100644
index 0000000..540da13
--- /dev/null
+++ b/lib/Lintian/Data/Policy/Releases.pm
@@ -0,0 +1,274 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Policy::Releases;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Date::Parse qw(str2time);
+use List::SomeUtils qw(first_value);
+use IPC::Run3;
+use HTTP::Tiny;
+use List::SomeUtils qw(minmax);
+use List::UtilsBy qw(rev_nsort_by);
+use Path::Tiny;
+use Time::Moment;
+use Unicode::UTF8 qw(decode_utf8 encode_utf8);
+
+const my $SLASH => q{/};
+
+const my $RELEASES => q{releases};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::PreambledJSON';
+
+=head1 NAME
+
+Lintian::Data::Policy::Releases - Lintian interface for policy releases
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Policy::Releases;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for policy releases.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item ordered_versions
+
+=item by_version
+
+=item max_dots
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Debian Policy Releases'
+);
+
+has location => (
+ is => 'rw',
+ default => 'debian-policy/releases.json'
+);
+
+has ordered_versions => (is => 'rw', default => sub { [] });
+has by_version => (is => 'rw', default => sub { {} });
+has max_dots => (is => 'rw');
+
+=item latest_version
+
+=cut
+
+sub latest_version {
+ my ($self) = @_;
+
+ return $self->ordered_versions->[0];
+}
+
+=item normalize
+
+=cut
+
+sub normalize {
+ my ($self, $version) = @_;
+
+ my $have = $version =~ tr{\.}{};
+ my $need = $self->max_dots - $have;
+
+ $version .= '.0' for (1..$need);
+
+ return $version;
+}
+
+=item is_known
+
+=cut
+
+sub is_known {
+ my ($self, $version) = @_;
+
+ my $normalized = $self->normalize($version);
+
+ return exists $self->by_version->{$normalized};
+}
+
+=item epoch
+
+=cut
+
+sub epoch {
+ my ($self, $version) = @_;
+
+ my $normalized = $self->normalize($version);
+
+ my $release = $self->by_version->{$normalized};
+ return undef
+ unless defined $release;
+
+ return $release->{epoch};
+}
+
+=item author
+
+=cut
+
+sub author {
+ my ($self, $version) = @_;
+
+ my $normalized = $self->normalize($version);
+
+ my $release = $self->by_version->{$normalized};
+ return undef
+ unless defined $release;
+
+ return $release->{author};
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ my $reference;
+ return 0
+ unless $self->read_file($path, \$reference);
+
+ my @releases = @{$reference // []};
+
+ my @sorted = rev_nsort_by { $_->{epoch} } @releases;
+ my @ordered_versions = map { $_->{version} } @sorted;
+ $self->ordered_versions(\@ordered_versions);
+
+ my @dot_count = map { tr{\.}{} } @ordered_versions;
+ my (undef, $max_dots) = minmax @dot_count;
+ $self->max_dots($max_dots);
+
+ # normalize versions
+ $_->{version} = $self->normalize($_->{version}) for @releases;
+
+ my %by_version;
+ $by_version{$_->{version}} = $_ for @releases;
+
+ $self->by_version(\%by_version);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $changelog_url
+ = 'https://salsa.debian.org/dbnpolicy/policy/-/raw/master/debian/changelog?inline=false';
+
+ my $response = HTTP::Tiny->new->get($changelog_url);
+ die encode_utf8("Failed to get $changelog_url!\n")
+ unless $response->{success};
+
+ my $tempfile_tiny = Path::Tiny->tempfile;
+ $tempfile_tiny->spew($response->{content});
+
+ my @command = (
+ qw{dpkg-parsechangelog --format rfc822 --all --file},
+ $tempfile_tiny->stringify
+ );
+ my $rfc822;
+ my $stderr;
+ run3(\@command, \undef, \$rfc822, \$stderr);
+ my $dpkg_status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # already in UTF-8
+ die $stderr
+ if $dpkg_status;
+
+ my $deb822 = Lintian::Deb822->new;
+ my @sections = $deb822->parse_string(decode_utf8($rfc822));
+
+ my @releases;
+ for my $section (@sections) {
+
+ my $epoch = str2time($section->value('Date'), 'GMT');
+ my $moment = Time::Moment->from_epoch($epoch);
+ my $timestamp = $moment->strftime('%Y-%m-%dT%H:%M:%S%Z');
+
+ my @closes = sort { $a <=> $b } $section->trimmed_list('Closes');
+ my @changes = split(/\n/, $section->text('Changes'));
+
+ my %release;
+ $release{version} = $section->value('Version');
+ $release{timestamp} = $timestamp;
+ $release{epoch} = $epoch;
+ $release{closes} = \@closes;
+ $release{changes} = \@changes;
+ $release{author} = $section->value('Maintainer');
+
+ push(@releases, \%release);
+ }
+
+ my @sorted = rev_nsort_by { $_->{epoch} } @releases;
+
+ my $data_path = "$basedir/" . $self->location;
+ my $write_status = $self->write_file($RELEASES, \@releases, $data_path);
+
+ return $write_status;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/PreambledJSON.pm b/lib/Lintian/Data/PreambledJSON.pm
new file mode 100644
index 0000000..e2af970
--- /dev/null
+++ b/lib/Lintian/Data/PreambledJSON.pm
@@ -0,0 +1,164 @@
+# -*- perl -*-
+
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::PreambledJSON;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(carp);
+use Const::Fast;
+use JSON::MaybeXS;
+use Path::Tiny;
+use Time::Piece;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+
+const my $PREAMBLE => q{preamble};
+const my $TITLE => q{title};
+const my $CARGO => q{cargo};
+
+=encoding utf-8
+
+=head1 NAME
+
+Lintian::Data::PreambledJSON -- Data in preambled JSON format
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::PreambledJSON;
+
+=head1 DESCRIPTION
+
+Routines for access and management of preambled JSON data files.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item last_modified
+
+=cut
+
+has cargo => (
+ is => 'rw',
+ coerce => sub { my ($scalar) = @_; return ($scalar // $EMPTY); }
+);
+
+=item read_file
+
+=cut
+
+sub read_file {
+ my ($self, $path, $double_reference) = @_;
+
+ if (!length $path || !-e $path) {
+
+ carp encode_utf8("Unknown data file: $path");
+ return 0;
+ }
+
+ my $json = path($path)->slurp;
+ my $data = decode_json($json);
+
+ my %preamble = %{$data->{$PREAMBLE}};
+ my $stored_title = $preamble{$TITLE};
+ my $storage_key = $preamble{$CARGO};
+
+ unless (length $stored_title && length $storage_key) {
+ warn encode_utf8("Please refresh data file $path: invalid format");
+ return 0;
+ }
+
+ unless ($stored_title eq $self->title) {
+ warn encode_utf8(
+ "Please refresh data file $path: wrong title $stored_title");
+ return 0;
+ }
+
+ if ($storage_key eq $PREAMBLE) {
+ warn encode_utf8(
+ "Please refresh data file $path: disallowed cargo key $storage_key"
+ );
+ return 0;
+ }
+
+ if (!exists $data->{$storage_key}) {
+ warn encode_utf8(
+ "Please refresh data file $path: cargo key $storage_key not found"
+ );
+ return 0;
+ }
+
+ ${$double_reference} = $data->{$storage_key};
+
+ return 1;
+}
+
+=item write_file
+
+=cut
+
+sub write_file {
+ my ($self, $storage_key, $reference, $path) = @_;
+
+ die
+"Cannot write preambled JSON data file $path: disallowed cargo key $storage_key"
+ if $storage_key eq $PREAMBLE;
+
+ my %preamble;
+ $preamble{$TITLE} = $self->title;
+ $preamble{$CARGO} = $storage_key;
+
+ my %combined;
+ $combined{$PREAMBLE} = \%preamble;
+ $combined{$storage_key} = $reference;
+
+ # convert to UTF-8 prior to encoding in JSON
+ my $encoder = JSON->new;
+ $encoder->canonical;
+ $encoder->utf8;
+ $encoder->pretty;
+
+ my $json = $encoder->encode(\%combined);
+
+ my $parentdir = path($path)->parent->stringify;
+ path($parentdir)->mkpath
+ unless -e $parentdir;
+
+ # already in UTF-8
+ path($path)->spew($json);
+
+ return 1;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Provides/MailTransportAgent.pm b/lib/Lintian/Data/Provides/MailTransportAgent.pm
new file mode 100644
index 0000000..51818f2
--- /dev/null
+++ b/lib/Lintian/Data/Provides/MailTransportAgent.pm
@@ -0,0 +1,193 @@
+# -*- perl -*-
+#
+# Copyright (C) 2008 Niko Tyni
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Provides::MailTransportAgent;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(carp);
+use Const::Fast;
+use List::SomeUtils qw(first_value any);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+const my $SLASH => q{/};
+
+const my $NEWLINE => qq{\n};
+
+=head1 NAME
+
+Lintian::Data::Provides::MailTransportAgent - Lintian interface for mail transport agents.
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Provides::MailTransportAgent;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files for mail transport agents.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item mail_transport_agents
+
+=item deb822_by_installable_name
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Mail Transport Agents'
+);
+
+has location => (
+ is => 'rw',
+ default => 'fields/mail-transport-agents'
+);
+
+has mail_transport_agents => (is => 'rw', default => sub { [] });
+
+=item all
+
+=cut
+
+sub all {
+ my ($self) = @_;
+
+ return keys %{$self->mail_transport_agents};
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ unless (length $path) {
+ carp encode_utf8('Unknown data file: ' . $self->location);
+ return 0;
+ }
+
+ open(my $fd, '<:utf8_strict', $path)
+ or die encode_utf8("Cannot open $path: $!");
+
+ my $position = 1;
+ while (my $line = <$fd>) {
+
+ # trim both ends
+ $line =~ s/^\s+|\s+$//g;
+
+ next
+ unless length $line;
+
+ next
+ if $line =~ m{^ [#]}x;
+
+ my $agent = $line;
+
+ push(@{$self->mail_transport_agents}, $agent);
+
+ } continue {
+ ++$position;
+ }
+
+ close $fd;
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my @mail_transport_agents;
+
+ # neutral sort order
+ local $ENV{LC_ALL} = 'C';
+
+ my $port = 'amd64';
+
+ my $deb822_by_installable_name
+ = $archive->deb822_packages_by_installable_name('sid', 'main', $port);
+
+ for my $installable_name (keys %{$deb822_by_installable_name}) {
+
+ my $deb822 = $deb822_by_installable_name->{$installable_name};
+
+ my @provides = $deb822->trimmed_list('Provides', qr{ \s* , \s* }x);
+
+ push(@mail_transport_agents, $installable_name)
+ if any { $_ eq 'mail-transport-agent' } @provides;
+ }
+
+ my $text = encode_utf8(<<'EOF');
+# Packages that provide mail-transport-agent
+#
+EOF
+
+ $text .= encode_utf8($_ . $NEWLINE)for sort @mail_transport_agents;
+
+ my $datapath = "$basedir/" . $self->location;
+ my $parentdir = path($datapath)->parent->stringify;
+ path($parentdir)->mkpath
+ unless -e $parentdir;
+
+ # already in UTF-8
+ path($datapath)->spew($text);
+
+ return 1;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Stylesheet.pm b/lib/Lintian/Data/Stylesheet.pm
new file mode 100644
index 0000000..bfc8c5b
--- /dev/null
+++ b/lib/Lintian/Data/Stylesheet.pm
@@ -0,0 +1,139 @@
+# -*- perl -*-
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Stylesheet;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(carp);
+use Const::Fast;
+use HTTP::Tiny;
+use List::SomeUtils qw(first_value);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Data::Stylesheet - Lintian interface to CSS style sheets
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Stylesheet;
+
+=head1 DESCRIPTION
+
+This module provides a way to load data files to CSS style sheets
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item title
+
+=item location
+
+=item C<css>
+
+=cut
+
+has title => (
+ is => 'rw',
+ default => 'Lintian CSS Style Sheet'
+);
+
+has location => (
+ is => 'rw',
+ default => 'stylesheets/lintian.css'
+);
+
+has css => (is => 'rw', default => $EMPTY);
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $search_space, $our_vendor) = @_;
+
+ my @candidates = map { $_ . $SLASH . $self->location } @{$search_space};
+ my $path = first_value { -e } @candidates;
+
+ unless (length $path) {
+ carp encode_utf8('Unknown data file: ' . $self->location);
+ return 0;
+ }
+
+ my $style_sheet = path($path)->slurp_utf8;
+
+ $self->css($style_sheet);
+
+ return 1;
+}
+
+=item refresh
+
+=cut
+
+sub refresh {
+ my ($self, $archive, $basedir) = @_;
+
+ my $css_url = 'https://lintian.debian.org/stylesheets/lintian.css';
+
+ my $response = HTTP::Tiny->new->get($css_url);
+ die encode_utf8("Failed to get $css_url!\n")
+ unless $response->{success};
+
+ my $style_sheet = $response->{content};
+
+ my $data_path = "$basedir/" . $self->location;
+ my $parent_dir = path($data_path)->parent->stringify;
+ path($parent_dir)->mkpath
+ unless -e $parent_dir;
+
+ # already in UTF-8
+ path($data_path)->spew($style_sheet);
+
+ return 1;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Data/Traditional.pm b/lib/Lintian/Data/Traditional.pm
new file mode 100644
index 0000000..9deaf12
--- /dev/null
+++ b/lib/Lintian/Data/Traditional.pm
@@ -0,0 +1,73 @@
+# -*- perl -*-
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Data::Traditional;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Data::JoinedLines';
+
+=head1 NAME
+
+Lintian::Data::Traditional - Lintian interface for generic data
+
+=head1 SYNOPSIS
+
+ use Lintian::Data::Traditional;
+
+=head1 DESCRIPTION
+
+Lintian::Data::Traditional provides a way to load generic, traditional
+data files.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item location
+
+=item separator
+
+=cut
+
+has location => (is => 'rw');
+has separator => (is => 'rw');
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Deb822.pm b/lib/Lintian/Deb822.pm
new file mode 100644
index 0000000..c153415
--- /dev/null
+++ b/lib/Lintian/Deb822.pm
@@ -0,0 +1,692 @@
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Deb822;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822::Constants qw(:constants);
+use Lintian::Deb822::Section;
+
+const my $EMPTY => q{};
+const my $NUMBER_SIGN => q{#};
+
+use Moo;
+use namespace::clean;
+
+=encoding utf-8
+
+=head1 NAME
+
+Lintian::Deb822 -- A deb822 control file
+
+=head1 SYNOPSIS
+
+ use Lintian::Deb822;
+
+=head1 DESCRIPTION
+
+Represents a paragraph in a Deb822 control file.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item sections
+
+Array of Deb822::Section objects in order of their original appearance.
+
+=item positions
+
+Line positions
+
+=cut
+
+has sections => (is => 'rw', default => sub { [] });
+has positions => (is => 'rw', default => sub { [] });
+
+=item first_mention
+
+=cut
+
+sub first_mention {
+ my ($self, $name) = @_;
+
+ my $earliest;
+
+ # empty when field not present
+ $earliest ||= $_->value($name) for @{$self->sections};
+
+ return ($earliest // $EMPTY);
+}
+
+=item last_mention
+
+=cut
+
+sub last_mention {
+ my ($self, $name) = @_;
+
+ my $latest;
+
+ for my $section (@{$self->sections}) {
+
+ # empty when field not present
+ $latest = $section->value($name)
+ if $section->declares($name);
+ }
+
+ return ($latest // $EMPTY);
+}
+
+=item read_file
+
+=cut
+
+sub read_file {
+ my ($self, $path, $flags) = @_;
+
+ my $contents = path($path)->slurp_utf8;
+
+ return $self->parse_string($contents, $flags);
+}
+
+=item parse_string
+
+=cut
+
+sub parse_string {
+ my ($self, $contents, $flags) = @_;
+
+ my (@paragraphs, @positions);
+
+ try {
+ @paragraphs= parse_dpkg_control_string($contents, $flags,\@positions);
+
+ } catch {
+ # ignore syntax errors here
+ die map { encode_utf8($_) } $@
+ unless $@ =~ /syntax error/;
+ }
+
+ my $index = 0;
+ for my $paragraph (@paragraphs) {
+
+ my $section = Lintian::Deb822::Section->new;
+ $section->verbatim($paragraph);
+ $section->positions($positions[$index]);
+
+ push(@{$self->sections}, $section);
+
+ } continue {
+ $index++;
+ }
+
+ return @{$self->sections};
+}
+
+=back
+
+=head1 FUNCTIONS
+
+=head2 Debian control parsers
+
+At first glance, this module appears to contain several debian control
+parsers. In practise, there is only one real parser
+(L</visit_dpkg_paragraph_string>) - the rest are convenience functions around
+it.
+
+=over 4
+
+=item read_dpkg_control(FILE[, FLAGS[, LINES]])
+
+This is a convenience function to ease using L</parse_dpkg_control>
+with paths to files (rather than open handles). The first argument
+must be the path to a FILE, which should be read as a debian control
+file. If the file is empty, an empty list is returned.
+
+Otherwise, this behaves like:
+
+ use autodie;
+
+ open(my $fd, '<:encoding(UTF-8)', FILE); # or '<'
+ my @p = parse_dpkg_control($fd, FLAGS, LINES);
+ close($fd);
+ return @p;
+
+This goes without saying that may fail with any of the messages that
+L</parse_dpkg_control(HANDLE[, FLAGS[, LINES]])> do. It can also emit
+autodie exceptions if open or close fails.
+
+=cut
+
+sub read_dpkg_control {
+ my ($file, $flags, $field_starts) = @_;
+
+ open(my $handle, '<:utf8_strict', $file)
+ or die encode_utf8("Cannot open $file");
+
+ local $/ = undef;
+ my $string = <$handle>;
+ close $handle;
+
+ my @result;
+
+ my $visitor = sub {
+ my ($paragraph, $line) = @_;
+
+ push(@result, $paragraph);
+ push(@{$field_starts}, $line) if defined $field_starts;
+ };
+
+ visit_dpkg_paragraph_string($visitor, $string, $flags);
+
+ return @result;
+}
+
+=item read_dpkg_control_lc(FILE[, FLAGS[, LINES]])
+
+=cut
+
+sub read_dpkg_control_lc {
+ my ($file, $flags, $field_starts) = @_;
+
+ my @result = read_dpkg_control($file, $flags, $field_starts);
+
+ lowercase_field_names(\@result);
+ lowercase_field_names($field_starts);
+
+ return @result;
+}
+
+=item parse_dpkg_control_string(STRING[, FLAGS[, LINES]])
+
+Reads debian control data from STRING and returns a list of
+paragraphs in it. A paragraph is represented via a hashref, which
+maps (lower cased) field names to their values.
+
+FLAGS (if given) is a bitmask of the I<DCTRL_*> constants. Please
+refer to L</CONSTANTS> for the list of constants and their meaning.
+The default value for FLAGS is 0.
+
+If LINES is given, it should be a reference to an empty list. On
+return, LINES will be populated with a hashref for each paragraph (in
+the same order as the returned list). Each hashref will also have a
+special key "I<START-OF-PARAGRAPH>" that gives the line number of the
+first field in that paragraph. These hashrefs will map the field name
+of the given paragraph to the line number where the field name
+appeared.
+
+This is a convenience sub around L</visit_dpkg_paragraph> and can
+therefore produce the same errors as it. Please see
+L</visit_dpkg_paragraph> for the finer semantics of how the
+control file is parsed.
+
+NB: parse_dpkg_control does I<not> close the handle for the caller.
+
+=cut
+
+sub parse_dpkg_control_string {
+ my ($string, $flags, $field_starts) = @_;
+ my @result;
+
+ my $c = sub {
+ my ($para, $line) = @_;
+
+ push(@result, $para);
+ push(@{$field_starts}, $line)
+ if defined $field_starts;
+ };
+
+ visit_dpkg_paragraph_string($c, $string, $flags);
+
+ return @result;
+}
+
+=item parse_dpkg_control_string_lc(STRING[, FLAGS[, LINES]])
+
+=cut
+
+sub parse_dpkg_control_string_lc {
+ my ($string, $flags, $field_starts) = @_;
+
+ my @result = parse_dpkg_control_string($string, $flags, $field_starts);
+
+ lowercase_field_names(\@result);
+ lowercase_field_names($field_starts);
+
+ return @result;
+}
+
+=item lowercase_field_names
+
+=cut
+
+sub lowercase_field_names {
+ my ($arrayref) = @_;
+
+ return
+ unless $arrayref;
+
+ for my $paragraph (@{$arrayref}) {
+
+ # magic marker should only appear in field starts
+ my @fields = grep { $_ ne 'START-OF-PARAGRAPH' } keys %{$paragraph};
+ my @mixedcase = grep { $_ ne lc } @fields;
+
+ for my $old (@mixedcase) {
+ $paragraph->{lc $old} = $paragraph->{$old};
+ delete $paragraph->{$old};
+ }
+ }
+
+ return;
+}
+
+=item visit_dpkg_paragraph_string (CODE, STRING[, FLAGS])
+
+Reads debian control data from STRING and passes each paragraph to
+CODE. A paragraph is represented via a hashref, which maps (lower
+cased) field names to their values.
+
+FLAGS (if given) is a bitmask of the I<DCTRL_*> constants. Please
+refer to L</CONSTANTS> for the list of constants and their meaning.
+The default value for FLAGS is 0.
+
+If the file is empty (i.e. it contains no paragraphs), the method will
+contain an I<empty> list. The deb822 contents may be inside a
+I<signed> PGP message with a signature.
+
+visit_dpkg_paragraph will require the PGP headers to be correct (if
+present) and require that the entire file is covered by the signature.
+However, it will I<not> validate the signature (in fact, the contents
+of the PGP SIGNATURE part can be empty). The signature should be
+validated separately.
+
+visit_dpkg_paragraph will pass paragraphs to CODE as they are
+completed. If CODE can process the paragraphs as they are seen, very
+large control files can be processed without keeping all the
+paragraphs in memory.
+
+As a consequence of how the file is parsed, CODE may be passed a
+number of (valid) paragraphs before parsing is stopped due to a syntax
+error.
+
+NB: visit_dpkg_paragraph does I<not> close the handle for the caller.
+
+CODE is expected to be a callable reference (e.g. a sub) and will be
+invoked as the following:
+
+=over 4
+
+=item CODE->(PARA, LINE_NUMBERS)
+
+The first argument, PARA, is a hashref to the most recent paragraph
+parsed. The second argument, LINE_NUMBERS, is a hashref mapping each
+of the field names to the line number where the field name appeared.
+LINE_NUMBERS will also have a special key "I<START-OF-PARAGRAPH>" that
+gives the line number of the first field in that paragraph.
+
+The return value of CODE is ignored.
+
+If the CODE invokes die (or similar) the error is propagated to the
+caller.
+
+=back
+
+
+I<On syntax errors>, visit_dpkg_paragraph will call die with the
+following string:
+
+ "syntax error at line %d: %s\n"
+
+Where %d is the line number of the issue and %s is one of:
+
+=over
+
+=item Duplicate field %s
+
+The field appeared twice in the paragraph.
+
+=item Continuation line outside a paragraph (maybe line %d should be " .")
+
+A continuation line appears outside a paragraph - usually caused by an
+unintended empty line before it.
+
+=item Whitespace line not allowed (possibly missing a ".")
+
+An empty continuation line was found. This usually means that a
+period is missing to denote an "empty line" in (e.g.) the long
+description of a package.
+
+=item Cannot parse line "%s"
+
+Generic error containing the text of the line that confused the
+parser. Note that all non-printables in %s will be replaced by
+underscores.
+
+=item Comments are not allowed
+
+A comment line appeared and FLAGS contained DCTRL_NO_COMMENTS.
+
+=item PGP signature seen before start of signed message
+
+A "BEGIN PGP SIGNATURE" header is seen and a "BEGIN PGP MESSAGE" has
+not been seen yet.
+
+=item Two PGP signatures (first one at line %d)
+
+Two "BEGIN PGP SIGNATURE" headers are seen in the same file.
+
+=item Unexpected %s header
+
+A valid PGP header appears (e.g. "BEGIN PUBLIC KEY BLOCK").
+
+=item Malformed PGP header
+
+An invalid or malformed PGP header appears.
+
+=item Expected at most one signed message (previous at line %d)
+
+Two "BEGIN PGP MESSAGE" headers appears in the same message.
+
+=item End of file but expected an "END PGP SIGNATURE" header
+
+The file ended after a "BEGIN PGP SIGNATURE" header without being
+followed by an "END PGP SIGNATURE".
+
+=item PGP MESSAGE header must be first content if present
+
+The file had content before PGP MESSAGE.
+
+=item Data after the PGP SIGNATURE
+
+The file had data after the PGP SIGNATURE block ended.
+
+=item End of file before "BEGIN PGP SIGNATURE"
+
+The file had a "BEGIN PGP MESSAGE" header, but no signature was
+present.
+
+=back
+
+=cut
+
+sub visit_dpkg_paragraph_string {
+ my ($code, $string, $flags) = @_;
+ $flags//=0;
+ my $field_starts = {};
+ my $section = {};
+ my $open_section = 0;
+ my $last_tag;
+ my $debconf = $flags & DCTRL_DEBCONF_TEMPLATE;
+ my $signed = 0;
+ my $signature = 0;
+
+ my @lines = split(/\n/, $string);
+
+ my $position = 1;
+
+ my $line;
+ while (defined($line = shift @lines)) {
+ chomp $line;
+
+ if (substr($line, 0, 1) eq $NUMBER_SIGN) {
+ next
+ unless $flags & DCTRL_NO_COMMENTS;
+ die encode_utf8("No comments allowed (line $position).\n");
+ }
+
+ # empty line?
+ if ($line eq $EMPTY || (!$debconf && $line =~ /^\s*$/)) {
+ if ($open_section) { # end of current section
+ # pass the current section to the handler
+ $code->($section, $field_starts);
+ $section = {};
+ $field_starts = {};
+ $open_section = 0;
+ }
+ }
+ # pgp sig? Be strict here (due to #696230)
+ # According to http://tools.ietf.org/html/rfc4880#section-6.2
+ # The header MUST start at the beginning of the line and MUST NOT have
+ # any other text (except whitespace) after the header.
+ elsif ($line =~ m/^-----BEGIN PGP SIGNATURE-----[ \r\t]*$/)
+ { # skip until end of signature
+ my $saw_end = 0;
+
+ die encode_utf8("PGP signature before message (line $position).\n")
+ unless $signed;
+
+ die encode_utf8(
+"Found two PGP signatures (line $signature and line $position).\n"
+ )if $signature;
+
+ $signature = $position;
+ while (defined($line = shift @lines)) {
+ if ($line =~ /^-----END PGP SIGNATURE-----[ \r\t]*$/) {
+ $saw_end = 1;
+ last;
+ }
+ }continue {
+ ++$position;
+ }
+
+ # The "at line X" may seem a little weird, but it keeps the
+ # message format identical.
+ die encode_utf8("Cannot find END PGP SIGNATURE header.\n")
+ unless $saw_end;
+ }
+ # other pgp control?
+ elsif ($line =~ /^-----(?:BEGIN|END) PGP/) {
+ # At this point it could be a malformed PGP header or one
+ # of the following valid headers (RFC4880):
+ # * BEGIN PGP MESSAGE
+ # - Possibly a signed Debian CTRL, so okay (for now)
+ # * BEGIN PGP {PUBLIC,PRIVATE} KEY BLOCK
+ # - Valid header, but not a Debian CTRL file.
+ # * BEGIN PGP MESSAGE, PART X{,/Y}
+ # - Valid, but we don't support partial messages, so
+ # bail on those.
+
+ unless ($line =~ /^-----BEGIN PGP SIGNED MESSAGE-----[ \r\t]*$/) {
+ # Not a (full) PGP MESSAGE; reject.
+
+ my $key = qr/(?:BEGIN|END) PGP (?:PUBLIC|PRIVATE) KEY BLOCK/;
+ my $msgpart = qr{BEGIN PGP MESSAGE, PART \d+(?:/\d+)?};
+ my $msg
+ = qr/(?:BEGIN|END) PGP (?:(?:COMPRESSED|ENCRYPTED) )?MESSAGE/;
+
+ if ($line =~ /^-----($key|$msgpart|$msg)-----[ \r\t]*$/) {
+ die encode_utf8(
+ "Unexpected $1 header (line $position).\n");
+ }
+
+ die encode_utf8("Malformed PGP header (line $position).\n");
+
+ } else {
+ die encode_utf8(
+"Multiple PGP messages (line $signed and line $position).\n"
+ )if $signed;
+
+ # NB: If you remove this, keep in mind that it may
+ # allow two paragraphs to merge. Consider:
+ #
+ # Field-P1: some-value
+ # -----BEGIN PGP SIGNATURE-----
+ #
+ # Field-P2: another value
+ #
+ # At the time of writing: If $open_section is
+ # true, it will remain so until the empty line
+ # after the PGP header.
+ die encode_utf8(
+ "Expected PGP MESSAGE header (line $position).\n")
+ if $last_tag;
+
+ $signed = $position;
+ }
+
+ # skip until the next blank line
+ while (defined($line = shift @lines)) {
+ last
+ if $line =~ /^\s*$/;
+ }continue {
+ ++$position;
+ }
+ }
+ # did we see a signature already? We allow all whitespace/comment lines
+ # outside the signature.
+ elsif ($signature) {
+ # Accept empty lines after the signature.
+ next
+ if $line =~ /^\s*$/;
+
+ # NB: If you remove this, keep in mind that it may allow
+ # two paragraphs to merge. Consider:
+ #
+ # Field-P1: some-value
+ # -----BEGIN PGP SIGNATURE-----
+ # [...]
+ # -----END PGP SIGNATURE-----
+ # Field-P2: another value
+ #
+ # At the time of writing: If $open_section is true, it
+ # will remain so until the empty line after the PGP
+ # header.
+ die encode_utf8("Data after PGP SIGNATURE (line $position).\n");
+ }
+ # new empty field?
+ elsif ($line =~ /^([^: \t]+):\s*$/) {
+ $field_starts->{'START-OF-PARAGRAPH'} = $position
+ unless $open_section;
+ $open_section = 1;
+
+ my $tag = $1;
+ $section->{$tag} = $EMPTY;
+ $field_starts->{$tag} = $position;
+
+ $last_tag = $tag;
+ }
+ # new field?
+ elsif ($line =~ /^([^: \t]+):\s*(.*)$/) {
+ $field_starts->{'START-OF-PARAGRAPH'} = $position
+ unless $open_section;
+ $open_section = 1;
+
+ # Policy: Horizontal whitespace (spaces and tabs) may occur
+ # immediately before or after the value and is ignored there.
+ my $tag = $1;
+ my $value = $2;
+
+ # trim right
+ $value =~ s/\s+$//;
+
+ if (exists $section->{$tag}) {
+ # Policy: A paragraph must not contain more than one instance
+ # of a particular field name.
+ die encode_utf8("Duplicate field $tag (line $position).\n");
+ }
+ $value =~ s/#.*$//
+ if $flags & DCTRL_COMMENTS_AT_EOL;
+ $section->{$tag} = $value;
+ $field_starts->{$tag} = $position;
+
+ $last_tag = $tag;
+ }
+
+ # continued field?
+ elsif ($line =~ /^([ \t].*\S.*)$/) {
+ die encode_utf8(
+"Continuation line not in paragraph (line $position). Missing a dot on the previous line?\n"
+ )unless $open_section;
+
+ # Policy: Many fields' values may span several lines; in this case
+ # each continuation line must start with a space or a tab. Any
+ # trailing spaces or tabs at the end of individual lines of a
+ # field value are ignored.
+ my $value = $1;
+
+ # trim right
+ $value =~ s/\s+$//;
+
+ $value =~ s/#.*$//
+ if $flags & DCTRL_COMMENTS_AT_EOL;
+ $section->{$last_tag} .= "\n" . $value;
+ }
+ # None of the above => syntax error
+ else {
+
+ die encode_utf8(
+ "Unexpected whitespace (line $position). Missing a dot?\n")
+ if $line =~ /^\s+$/;
+
+ # Replace non-printables and non-space characters with
+ # "_" - just in case.
+ $line =~ s/[^[:graph:][:space:]]/_/g;
+
+ die encode_utf8("Cannot parse line $position: $line\n");
+ }
+
+ }continue {
+ ++$position;
+ }
+
+ # pass the last section (if not already done).
+ $code->($section, $field_starts)
+ if $open_section;
+
+ # Given the API, we cannot use this check to prevent any
+ # paragraphs from being emitted to the code argument, so we might
+ # as well just do this last.
+
+ die encode_utf8("Cannot find BEGIN PGP SIGNATURE\n.")
+ if $signed && !$signature;
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written Christian Schwarz and many other people.
+
+Moo version by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Deb822/Constants.pm b/lib/Lintian/Deb822/Constants.pm
new file mode 100644
index 0000000..a30e117
--- /dev/null
+++ b/lib/Lintian/Deb822/Constants.pm
@@ -0,0 +1,87 @@
+# Hey emacs! This is a -*- Perl -*- script!
+# Lintian::Deb822::Constants -- Perl utility functions for parsing deb822 files
+
+# Copyright (C) 1998 Christian Schwarz
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Deb822::Constants;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use constant {
+ DCTRL_DEBCONF_TEMPLATE => 1,
+ DCTRL_NO_COMMENTS => 2,
+ DCTRL_COMMENTS_AT_EOL => 4,
+};
+
+our %EXPORT_TAGS = (constants =>
+ [qw(DCTRL_DEBCONF_TEMPLATE DCTRL_NO_COMMENTS DCTRL_COMMENTS_AT_EOL)],);
+
+our @EXPORT_OK = (@{ $EXPORT_TAGS{constants} });
+
+use Exporter qw(import);
+
+=head1 NAME
+
+Lintian::Deb822::Constants - Lintian's generic Deb822 constants
+
+=head1 SYNOPSIS
+
+ use Lintian::Deb822::Constants qw(DCTRL_NO_COMMENTS);
+
+=head1 DESCRIPTION
+
+This module contains a number of utility subs that are nice to have,
+but on their own did not warrant their own module.
+
+Most subs are imported only on request.
+
+=head1 CONSTANTS
+
+The following constants can be passed to the Debian control file
+parser functions to alter their parsing flag.
+
+=over 4
+
+=item DCTRL_DEBCONF_TEMPLATE
+
+The file should be parsed as debconf template. These have slightly
+syntax rules for whitespace in some cases.
+
+=item DCTRL_NO_COMMENTS
+
+The file do not allow comments. With this flag, any comment in the
+file is considered a syntax error.
+
+=back
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Deb822/Section.pm b/lib/Lintian/Deb822/Section.pm
new file mode 100644
index 0000000..5950ee4
--- /dev/null
+++ b/lib/Lintian/Deb822/Section.pm
@@ -0,0 +1,373 @@
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Deb822::Section;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::Compare;
+
+const my $EMPTY => q{};
+
+const my $UNKNOWN_POSITION => -1;
+
+use Moo;
+use namespace::clean;
+
+=encoding utf-8
+
+=head1 NAME
+
+Lintian::Deb822::Section -- A paragraph in a control file
+
+=head1 SYNOPSIS
+
+ use Lintian::Deb822::Section;
+
+=head1 DESCRIPTION
+
+Represents a paragraph in a Deb822 control file.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item legend
+
+Returns exact field names for their lowercase versions.
+
+=item verbatim
+
+Returns a hash to the raw, unedited and verbatim field values.
+
+=item unfolded
+
+Returns a hash to unfolded field values. Continuations lines
+have been connected.
+
+=item positions
+
+The original line positions.
+
+=cut
+
+has legend => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my %legend;
+
+ for my $key (keys %{$self->verbatim}) {
+
+ my $lowercase = lc $key;
+ $legend{$lowercase} = $key;
+ }
+
+ return \%legend;
+ }
+);
+
+has verbatim => (is => 'rw', default => sub { {} });
+has unfolded => (is => 'rw', default => sub { {} });
+has positions => (is => 'rw', default => sub { {} });
+
+=item trimmed_list(FIELD [, SEPARATOR])
+
+=cut
+
+sub trimmed_list {
+ my ($self, $name, $regex) = @_;
+
+ $regex //= qr/\s+/;
+
+ my $value = $self->value($name);
+
+ # trim both ends
+ $value =~ s/^\s+|\s+$//g;
+
+ my @list = split($regex, $value);
+
+ # trim both ends of each element
+ s/^\s+|\s+$//g for @list;
+
+ return grep { length } @list;
+}
+
+=item unfolded_value (FIELD)
+
+This method returns the unfolded value of the control field FIELD in
+the control file for the package. For a source package, this is the
+*.dsc file; for a binary package, this is the control file in the
+control section of the package.
+
+If FIELD is passed but not present, then this method returns undef.
+
+=cut
+
+sub unfolded_value {
+ my ($self, $name) = @_;
+
+ return $EMPTY
+ unless length $name;
+
+ my $lowercase = lc $name;
+
+ my $unfolded = $self->unfolded->{$lowercase};
+ return $unfolded
+ if defined $unfolded;
+
+ my $value = $self->value($name);
+
+ # will also replace a newline at the very end
+ $value =~ s/\n//g;
+
+ # Remove leading space as it confuses some of the other checks
+ # that are anchored. This happens if the field starts with a
+ # space and a newline, i.e ($ marks line end):
+ #
+ # Vcs-Browser: $
+ # http://somewhere.com/$
+ $value =~ s/^\s*+//;
+
+ $self->unfolded->{$lowercase} = $value;
+
+ return $value;
+}
+
+=item value (FIELD)
+
+If FIELD is given, this method returns the value of the control field
+FIELD.
+
+=cut
+
+sub value {
+ my ($self, $name) = @_;
+
+ return $EMPTY
+ unless length $name;
+
+ my $exact = $self->legend->{lc $name};
+ return $EMPTY
+ unless length $exact;
+
+ my $trimmed = $self->verbatim->{$exact} // $EMPTY;
+
+ # trim both ends
+ $trimmed =~ s/^\s+|\s+$//g;
+
+ return $trimmed;
+}
+
+=item untrimmed_value (FIELD)
+
+If FIELD is given, this method returns the value of the control field
+FIELD.
+
+=cut
+
+sub untrimmed_value {
+ my ($self, $name) = @_;
+
+ return $EMPTY
+ unless length $name;
+
+ my $exact = $self->legend->{lc $name};
+ return $EMPTY
+ unless length $exact;
+
+ return $self->verbatim->{$exact} // $EMPTY;
+}
+
+=item text (FIELD)
+
+=cut
+
+sub text {
+ my ($self, $name) = @_;
+
+ my $text = $self->untrimmed_value($name);
+
+ # remove leading space in each line
+ $text =~ s/^[ \t]//mg;
+
+ # remove dot place holder for empty lines
+ $text =~ s/^\.$//mg;
+
+ return $text;
+}
+
+=item store (FIELD, VALUE)
+
+=cut
+
+sub store {
+ my ($self, $name, $value) = @_;
+
+ $value //= $EMPTY;
+
+ return
+ unless length $name;
+
+ my $exact = $self->legend->{lc $name};
+
+ # add new value if key not found
+ unless (defined $exact) {
+
+ $exact = $name;
+
+ # update legend with exact spelling
+ $self->legend->{lc $exact} = $exact;
+
+ # remove any old position
+ $self->positions->{$exact} = $UNKNOWN_POSITION;
+ }
+
+ $self->verbatim->{$exact} = $value;
+
+ # remove old unfolded value, if any
+ delete $self->unfolded->{$exact};
+
+ return;
+}
+
+=item drop (FIELD)
+
+=cut
+
+sub drop {
+ my ($self, $name) = @_;
+
+ return
+ unless length $name;
+
+ my $exact = $self->legend->{lc $name};
+ return
+ unless length $exact;
+
+ delete $self->legend->{lc $exact};
+
+ delete $self->verbatim->{$exact};
+ delete $self->unfolded->{$exact};
+ delete $self->positions->{$exact};
+
+ return;
+}
+
+=item declares (NAME)
+
+Returns a boolean for whether the named field exists.
+
+=cut
+
+sub declares {
+ my ($self, $name) = @_;
+
+ return 1
+ if defined $self->legend->{lc $name};
+
+ return 0;
+}
+
+=item names
+
+Returns an array with the literal field names.
+
+=cut
+
+sub names {
+ my ($self) = @_;
+
+ return keys %{$self->verbatim};
+}
+
+=item literal_name
+
+Returns an array with the literal, true case field names.
+
+=cut
+
+sub literal_name {
+ my ($self, $anycase) = @_;
+
+ return $self->legend->{ lc $anycase };
+}
+
+=item position
+
+With an argument, returns the starting line of the named field.
+
+Without an argument, return the starting line of the paragraph.
+
+=cut
+
+sub position {
+ my ($self, $field) = @_;
+
+ return $self->positions->{'START-OF-PARAGRAPH'}
+ unless length $field;
+
+ my $exact = $self->legend->{lc $field};
+ return undef
+ unless length $exact;
+
+ return $self->positions->{$exact};
+}
+
+=item extra
+
+=cut
+
+sub extra {
+ my ($self, @reference) = @_;
+
+ my @lowercase = map { lc } @reference;
+
+ my $extra_lc
+ = List::Compare->new([keys %{$self->legend}], \@lowercase);
+ my @extra_lowercase = $extra_lc->get_Lonly;
+
+ my @extra = map { $self->literal_name($_) } @extra_lowercase;
+
+ return @extra;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Debian/Control.pm b/lib/Lintian/Debian/Control.pm
new file mode 100644
index 0000000..cd99302
--- /dev/null
+++ b/lib/Lintian/Debian/Control.pm
@@ -0,0 +1,198 @@
+# -*- perl -*-
+# Lintian::Debian::Control -- object for fields in d/control
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Debian::Control;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Deb822;
+use Lintian::Deb822::Section;
+use Lintian::Util qw($PKGNAME_REGEX);
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Debian::Control - Lintian interface to d/control fields
+
+=head1 SYNOPSIS
+
+ use Lintian::Debian::Control;
+
+=head1 DESCRIPTION
+
+Lintian::Debian::Control provides access to fields in d/control.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item item
+=item source_fields
+=item installable_fields_by_name
+
+=cut
+
+has item => (is => 'rw');
+
+has source_fields => (
+ is => 'rw',
+ default => sub { return Lintian::Deb822::Section->new; },
+ coerce => sub {
+ my ($blessedref) = @_;
+ return ($blessedref // Lintian::Deb822::Section->new);
+ },
+);
+
+has installable_fields_by_name => (
+ is => 'rw',
+ default => sub { {} },
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+);
+
+=item load
+
+=cut
+
+sub load {
+ my ($self, $item) = @_;
+
+ return
+ unless defined $item;
+
+ $self->item($item);
+
+ return
+ unless -r $item->unpacked_path;
+
+ my $deb822 = Lintian::Deb822->new;
+
+ my @sections;
+ try {
+ @sections = $deb822->read_file($item->unpacked_path);
+
+ } catch {
+ # If it is a syntax error, ignore it (we emit
+ # syntax-error-in-control-file in this case via
+ # control-file).
+ die map { encode_utf8($_) } $@
+ unless $@ =~ /syntax error/;
+
+ return;
+ }
+
+ # in theory, one could craft a package in which d/control is empty
+ my $source = shift @sections;
+ $self->source_fields($source);
+
+ my @named
+ = grep { $_->value('Package') =~ m{\A $PKGNAME_REGEX \Z}x }@sections;
+
+ my %by_name = map { $_->value('Package') => $_ } @named;
+
+ $self->installable_fields_by_name(\%by_name);
+
+ return;
+}
+
+=item installables
+
+Returns a list of the binary and udeb packages listed in the
+F<debian/control>.
+
+=cut
+
+sub installables {
+ my ($self) = @_;
+
+ return keys %{$self->installable_fields_by_name};
+}
+
+=item installable_package_type (NAME)
+
+Returns package type based on value of the Package-Type (or if absent,
+X-Package-Type) field. If the field is omitted, the default value
+"deb" is used.
+
+If NAME is not an installable listed in the source packages
+F<debian/control> file, this method return C<undef>.
+
+=cut
+
+sub installable_package_type {
+ my ($self, $name) = @_;
+
+ my $type;
+
+ my $fields = $self->installable_fields_by_name->{$name};
+
+ $type = $fields->value('Package-Type') || $fields->value('XC-Package-Type')
+ if defined $fields;
+
+ $type ||= 'deb';
+
+ return lc $type;
+}
+
+=item installable_fields (PACKAGE)
+
+Returns the Deb822::Section object for the installable. Returns an
+empty object if the installable does not exist.
+
+=cut
+
+sub installable_fields {
+ my ($self, $package) = @_;
+
+ my $per_package;
+
+ $per_package = $self->installable_fields_by_name->{$package}
+ if length $package;
+
+ return ($per_package // Lintian::Deb822::Section->new);
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Elf/Section.pm b/lib/Lintian/Elf/Section.pm
new file mode 100644
index 0000000..f5ff7af
--- /dev/null
+++ b/lib/Lintian/Elf/Section.pm
@@ -0,0 +1,156 @@
+# Copyright (C) 2021 Felix Lechner <felix.lechner@lease-up.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Elf::Section;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Elf::Section -- ELF Sections
+
+=head1 SYNOPSIS
+
+ use Lintian::Elf::Section;
+
+=head1 DESCRIPTION
+
+A class for storing ELF section data
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item number
+
+=item name
+
+=item type
+
+=item address
+
+=item offset
+
+=item size
+
+=item entry_size
+
+=item flags
+
+=item index_link
+
+=item index_info
+
+=item alignment
+
+=cut
+
+has number => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return ($number // 0); },
+ default => 0
+);
+
+has name => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+has type => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+has address => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return ($number // 0); },
+ default => 0
+);
+
+has offset => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return ($number // 0); },
+ default => 0
+);
+
+has size => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return ($number // 0); },
+ default => 0
+);
+
+has entry_size => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return ($number // 0); },
+ default => 0
+);
+
+has flags => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+has index_link => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return ($number // 0); },
+ default => 0
+);
+
+has index_info => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return ($number // 0); },
+ default => 0
+);
+
+has alignment => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Elf/Symbol.pm b/lib/Lintian/Elf/Symbol.pm
new file mode 100644
index 0000000..ae20dd0
--- /dev/null
+++ b/lib/Lintian/Elf/Symbol.pm
@@ -0,0 +1,90 @@
+# Copyright (C) 2021 Felix Lechner <felix.lechner@lease-up.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Elf::Symbol;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Elf::Symbol -- ELF Symbols
+
+=head1 SYNOPSIS
+
+ use Lintian::Elf::Symbol;
+
+=head1 DESCRIPTION
+
+A class for storing ELF symbol data
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item name
+
+=item version
+
+=item section
+
+=cut
+
+has name => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+has version => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+has section => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Group.pm b/lib/Lintian/Group.pm
new file mode 100644
index 0000000..010f42e
--- /dev/null
+++ b/lib/Lintian/Group.pm
@@ -0,0 +1,794 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Group;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Cwd;
+use Devel::Size qw(total_size);
+use Email::Address::XS;
+use File::Spec;
+use List::Compare;
+use List::SomeUtils qw(any none uniq firstval true);
+use List::UtilsBy qw(sort_by);
+use POSIX qw(ENOENT);
+use Syntax::Keyword::Try;
+use Time::HiRes qw(gettimeofday tv_interval);
+use Time::Piece;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Hint::Pointed;
+use Lintian::Mask;
+use Lintian::Util qw(human_bytes match_glob);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $UNDERSCORE => q{_};
+
+const my $EXTRA_VERBOSE => 3;
+
+# A private table of supported types.
+const my %SUPPORTED_TYPES => (
+ 'binary' => 1,
+ 'buildinfo' => 1,
+ 'changes' => 1,
+ 'source' => 1,
+ 'udeb' => 1,
+);
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Group -- A group of objects that Lintian can process
+
+=head1 SYNOPSIS
+
+ use Lintian::Group;
+
+ my $group = Lintian::Group->new('lintian_2.5.0_i386.changes');
+
+=head1 DESCRIPTION
+
+Instances of this perl class are sets of
+L<processables|Lintian::Processable>. It allows at most one source
+and one changes or buildinfo package per set, but multiple binary packages
+(provided that the binary is not already in the set).
+
+=head1 METHODS
+
+=over 4
+
+=item $group->pooldir
+
+Returns or sets the pool directory used by this group.
+
+=item $group->source_name
+
+=item $group->source_version
+
+=item $group->binary
+
+Returns a hash reference to the binary processables in this group.
+
+=item $group->buildinfo
+
+Returns the buildinfo processable in this group.
+
+=item $group->changes
+
+Returns the changes processable in this group.
+
+=item $group->source
+
+Returns the source processable in this group.
+
+=item $group->udeb
+
+Returns a hash reference to the udeb processables in this group.
+
+=item jobs
+
+Returns or sets the max number of jobs to be processed in parallel.
+
+If the limit is 0, then there is no limit for the number of parallel
+jobs.
+
+=item processing_start
+
+=item processing_end
+
+=item cache
+
+Cache for some items.
+
+=item profile
+
+Hash with active jobs.
+
+=item C<saved_direct_dependencies>
+
+=item C<saved_direct_reliants>
+
+=cut
+
+has pooldir => (is => 'rw', default => $EMPTY);
+has source_name => (is => 'rw', default => $EMPTY);
+has source_version => (is => 'rw', default => $EMPTY);
+
+has binary => (is => 'rw', default => sub{ {} });
+has buildinfo => (is => 'rw');
+has changes => (is => 'rw');
+has source => (is => 'rw');
+has udeb => (is => 'rw', default => sub{ {} });
+
+has jobs => (is => 'rw', default => 1);
+has processing_start => (is => 'rw', default => $EMPTY);
+has processing_end => (is => 'rw', default => $EMPTY);
+
+has cache => (is => 'rw', default => sub { {} });
+has profile => (is => 'rw', default => sub { {} });
+
+=item $group->name
+
+Returns a unique identifier for the group based on source and version.
+
+=cut
+
+sub name {
+ my ($self) = @_;
+
+ return $EMPTY
+ unless length $self->source_name && length $self->source_version;
+
+ return $self->source_name . $UNDERSCORE . $self->source_version;
+}
+
+=item process
+
+Process group.
+
+=cut
+
+sub process {
+ my ($self, $ignored_overrides, $option)= @_;
+
+ my $groupname = $self->name;
+ local $SIG{__WARN__}
+ = sub { warn encode_utf8("Warning in group $groupname: $_[0]") };
+
+ my $savedir = getcwd;
+
+ $self->processing_start(gmtime->datetime . 'Z');
+ say {*STDERR} encode_utf8('Starting on group ' . $self->name)
+ if $option->{debug};
+ my $group_timer = [gettimeofday];
+
+ my $success = 1;
+ for my $processable ($self->get_processables){
+
+ my $path = $processable->path;
+ local $SIG{__WARN__}
+ = sub { warn encode_utf8("Warning in processable $path: $_[0]") };
+
+ my @hints;
+ my %enabled_overrides;
+
+ say {*STDERR}
+ encode_utf8(
+ 'Base directory for processable: '. $processable->basedir)
+ if $option->{debug};
+
+ unless ($option->{'no-override'}) {
+
+ say {*STDERR} encode_utf8('Loading overrides file (if any) ...')
+ if $option->{debug};
+
+ for my $override (@{$processable->overrides}) {
+
+ my $pattern = $override->pattern;
+
+ # catch renames
+ my $tag_name
+ = $self->profile->get_current_name($override->tag_name);
+
+ # catches unknown tags
+ next
+ unless length $tag_name;
+
+ next
+ unless $self->profile->tag_is_enabled($tag_name);
+
+ my @architectures = @{$override->architectures};
+
+ # count negations
+ my $negations = true { /^!/ } @architectures;
+
+ # strip negations if present
+ s/^!// for @architectures;
+
+ # enable overrides for this architecture
+ # proceed when none specified
+ my $data = $self->profile->data;
+ next
+ if @architectures
+ && (
+ $negations xor none {
+ $data->architectures->restriction_matches($_,
+ $processable->architecture)
+ }@architectures
+ );
+
+ if ($self->profile->is_durable($tag_name)) {
+
+ ++$ignored_overrides->{$tag_name};
+ next;
+ }
+
+ $enabled_overrides{$tag_name}{$pattern} = $override;
+ }
+ }
+
+ my @check_names = sort $self->profile->enabled_checks;
+
+ my @from_checks;
+ for my $name (@check_names) {
+
+ my $absolute = $self->profile->check_path_by_name->{$name};
+ require $absolute;
+
+ my $module = $self->profile->check_module_by_name->{$name};
+ my $check = $module->new;
+
+ $check->name($name);
+ $check->processable($processable);
+ $check->group($self);
+ $check->profile($self->profile);
+
+ my $timer = [gettimeofday];
+ my $procid = $processable->identifier;
+ say {*STDERR} encode_utf8("Running check: $name on $procid ...")
+ if $option->{debug};
+
+ try {
+ my @found_here = $check->run;
+ push(@from_checks, @found_here);
+
+ } catch {
+ my $message = $@;
+ $message
+ .= "warning: cannot run $name check on package $procid\n";
+ $message .= "skipping check of $procid\n";
+ warn encode_utf8($message);
+
+ $success = 0;
+
+ next;
+ }
+
+ my $raw_res = tv_interval($timer);
+ my $tres = sprintf('%.3fs', $raw_res);
+
+ say {*STDERR} encode_utf8("Check $name for $procid done ($tres)")
+ if $option->{debug};
+ say {*STDERR} encode_utf8("$procid,check/$name,$raw_res")
+ if $option->{'perf-output'};
+ }
+
+ my %context_tracker;
+ my %used_overrides;
+
+ for my $hint (@from_checks) {
+
+ my $as_issued = $hint->tag_name;
+
+ croak encode_utf8('No tag name')
+ unless length $as_issued;
+
+ my $issuer = $hint->issued_by;
+
+ # try local name space
+ my $tag = $self->profile->get_tag("$issuer/$as_issued");
+
+ warn encode_utf8(
+"Using tag $as_issued as name spaced while not so declared (in check $issuer)."
+ )if defined $tag && !$tag->name_spaced;
+
+ # try global name space
+ $tag ||= $self->profile->get_tag($as_issued);
+
+ unless (defined $tag) {
+ warn encode_utf8(
+ "Tried to issue unknown tag $as_issued in check $issuer.");
+ next;
+ }
+
+ if ( !$tag->name_spaced && $tag->name ne $as_issued
+ || $tag->name_spaced && $tag->name ne "$issuer/$as_issued") {
+
+ my $current_name = $tag->name;
+ warn encode_utf8(
+"Tried to issue renamed tag $as_issued (current name $current_name) in check $issuer."
+ );
+
+ next;
+ }
+
+ my $owner = $tag->check;
+ if ($issuer ne $owner) {
+ warn encode_utf8(
+ "Check $issuer has no tag $as_issued (but $owner does).");
+ next;
+ }
+
+ # pull name from tag; could be name-spaced
+ $hint->tag_name($tag->name);
+ my $tag_name = $hint->tag_name;
+
+ # skip disabled tags
+ next
+ unless $self->profile->tag_is_enabled($tag_name);
+
+ my $context = $hint->context;
+
+ if (exists $context_tracker{$tag_name}{$context}) {
+ warn encode_utf8(
+"Tried to issue duplicate hint in check $issuer: $tag_name $context\n"
+ );
+ next;
+ }
+
+ $context_tracker{$tag_name}{$context} = 1;
+
+ my @masks;
+ for my $screen (@{$tag->screens}) {
+
+ next
+ unless $screen->suppress($processable, $hint);
+
+ my $mask = Lintian::Mask->new;
+ $mask->screen($screen->name);
+
+ push(@masks, $mask);
+ }
+
+ my @screen_names = map { $_->screen } @masks;
+ my $screen_list = join($SPACE, (sort @screen_names));
+
+ warn encode_utf8("Crossing screens for $tag_name ($screen_list)")
+ if @masks > 1;
+
+ $hint->masks(\@masks)
+ if !$tag->show_always;
+
+ if (exists $enabled_overrides{$tag_name}) {
+
+ my $for_tag = $enabled_overrides{$tag_name};
+
+ if (exists $for_tag->{$EMPTY}) {
+ $hint->override($for_tag->{$EMPTY});
+
+ } else {
+
+ # overrides without context handled above
+ my @patterns = grep { length } keys %{$for_tag};
+
+ # try short ones first
+ my @by_length = sort_by { length } @patterns;
+
+ my $match = firstval {
+ match_glob($_, $hint->context)
+ }
+ @by_length;
+
+ $hint->override($for_tag->{$match})
+ if defined $match;
+ }
+ }
+
+ # new hash values autovivify to 0
+ ++$used_overrides{$tag_name}{$hint->override->pattern}
+ if defined $hint->override;
+
+ push(@hints, $hint);
+ }
+
+ # look for unused overrides
+ for my $tag_name (keys %enabled_overrides) {
+
+ my @declared_patterns = keys %{$enabled_overrides{$tag_name}};
+ my @used_patterns = keys %{$used_overrides{$tag_name} // {}};
+
+ my $pattern_lc
+ = List::Compare->new(\@declared_patterns, \@used_patterns);
+ my @unused_patterns = $pattern_lc->get_Lonly;
+
+ for my $pattern (@unused_patterns) {
+
+ my $override = $enabled_overrides{$tag_name}{$pattern};
+
+ my $override_item = $processable->override_file;
+ my $position = $override->position;
+ my $pointer = $override_item->pointer($position);
+
+ my $unused = Lintian::Hint::Pointed->new;
+ $unused->issued_by('lintian');
+
+ $unused->tag_name('unused-override');
+ $unused->tag_name('mismatched-override')
+ if exists $context_tracker{$tag_name};
+
+ # use the original name, in case the tag was renamed
+ my $original_name = $override->tag_name;
+ $unused->note($original_name . $SPACE . $pattern);
+
+ $unused->pointer($pointer);
+
+ # cannot be overridden or suppressed
+ push(@hints, $unused);
+ }
+ }
+
+ # carry hints into the output modules
+ $processable->hints(\@hints);
+ }
+
+ $self->processing_end(gmtime->datetime . 'Z');
+
+ my $raw_res = tv_interval($group_timer);
+ my $tres = sprintf('%.3fs', $raw_res);
+ say {*STDERR}
+ encode_utf8('Checking all of group ' . $self->name . " done ($tres)")
+ if $option->{debug};
+ say {*STDERR} encode_utf8($self->name . ",total-group-check,$raw_res")
+ if $option->{'perf-output'};
+
+ if ($option->{'debug'} > 2) {
+
+ # suppress warnings without reliable sizes
+ local $Devel::Size::warn = 0;
+
+ my @processables = $self->get_processables;
+ my $pivot = shift @processables;
+ my $group_id
+ = $pivot->source_name . $UNDERSCORE . $pivot->source_version;
+ my $group_usage
+ = human_bytes(total_size([map { $_ } $self->get_processables]));
+ say {*STDERR}
+ encode_utf8("Memory usage [group:$group_id]: $group_usage")
+ if $option->{debug} >= $EXTRA_VERBOSE;
+
+ for my $processable ($self->get_processables) {
+ my $id = $processable->identifier;
+ my $usage = human_bytes(total_size($processable));
+
+ say {*STDERR} encode_utf8("Memory usage [$id]: $usage")
+ if $option->{debug} >= $EXTRA_VERBOSE;
+ }
+ }
+
+ # change to known folder; ealier failures could prevent removal below
+ chdir $savedir
+ or warn encode_utf8("Cannot change to directory $savedir");
+
+ return $success;
+}
+
+=item $group->add_processable($proc)
+
+Adds $proc to $group. At most one source and one changes $proc can be
+in a $group. There can be multiple binary $proc's, as long as they
+are all unique. Successive buildinfo $proc's are silently ignored.
+
+This will error out if an additional source or changes $proc is added
+to the group. Otherwise it will return a truth value if $proc was
+added.
+
+=cut
+
+sub add_processable {
+ my ($self, $processable) = @_;
+
+ if ($processable->tainted) {
+ warn encode_utf8(
+ sprintf(
+ "warning: tainted %1\$s package '%2\$s', skipping\n",
+ $processable->type, $processable->name
+ )
+ );
+ return 0;
+ }
+
+ $self->source_name($processable->source_name)
+ unless length $self->source_name;
+ $self->source_version($processable->source_version)
+ unless length $self->source_version;
+
+ return 0
+ if $self->source_name ne $processable->source_name
+ || $self->source_version ne $processable->source_version;
+
+ croak encode_utf8('Please set pool directory first.')
+ unless $self->pooldir;
+
+ $processable->pooldir($self->pooldir);
+
+ croak encode_utf8('Not a supported type (' . $processable->type . ')')
+ unless exists $SUPPORTED_TYPES{$processable->type};
+
+ if ($processable->type eq 'changes') {
+ die encode_utf8('Cannot add another ' . $processable->type . ' file')
+ if $self->changes;
+ $self->changes($processable);
+
+ } elsif ($processable->type eq 'buildinfo') {
+ # Ignore multiple .buildinfo files; use the first one
+ $self->buildinfo($processable)
+ unless $self->buildinfo;
+
+ } elsif ($processable->type eq 'source'){
+ die encode_utf8('Cannot add another source package')
+ if $self->source;
+ $self->source($processable);
+
+ } else {
+ my $type = $processable->type;
+ die encode_utf8('Unknown type ' . $type)
+ unless $type eq 'binary' || $type eq 'udeb';
+
+ # check for duplicate; should be rewritten with arrays
+ my $id = $processable->identifier;
+ return 0
+ if exists $self->$type->{$id};
+
+ $self->$type->{$id} = $processable;
+ }
+
+ return 1;
+}
+
+=item get_processables
+
+Returns an array of all processables in $group.
+
+=cut
+
+sub get_processables {
+ my ($self) = @_;
+
+ my @processables;
+
+ push(@processables, $self->changes)
+ if defined $self->changes;
+
+ push(@processables, $self->source)
+ if defined $self->source;
+
+ push(@processables, $self->buildinfo)
+ if defined $self->buildinfo;
+
+ push(@processables, $self->get_installables);
+
+ return @processables;
+}
+
+=item get_installables
+
+Returns all binary (and udeb) processables in $group.
+
+If $group does not have any binary processables then an empty list is
+returned.
+
+=cut
+
+sub get_installables {
+ my ($self) = @_;
+
+ my @installables;
+
+ push(@installables, values %{$self->binary});
+ push(@installables, values %{$self->udeb});
+
+ return @installables;
+}
+
+=item direct_dependencies (PROC)
+
+If PROC is a part of the underlying processable group, this method
+returns a listref containing all the direct dependencies of PROC. If
+PROC is not a part of the group, this returns undef.
+
+Note: Only strong dependencies (Pre-Depends and Depends) are
+considered.
+
+Note: Self-dependencies (if any) are I<not> included in the result.
+
+=cut
+
+has saved_direct_dependencies => (is => 'rw', default => sub { {} });
+
+sub direct_dependencies {
+ my ($self, $processable) = @_;
+
+ unless (keys %{$self->saved_direct_dependencies}) {
+
+ my @processables = $self->get_installables;
+
+ my %dependencies;
+ for my $that (@processables) {
+
+ my $relation = $that->relation('strong');
+ my @specific;
+
+ for my $this (@processables) {
+
+ # Ignore self deps - we have checks for that and it
+ # will just end up complicating "correctness" of
+ # otherwise simple checks.
+ next
+ if $this->name eq $that->name;
+
+ push @specific, $this
+ if $relation->satisfies($this->name);
+ }
+ $dependencies{$that->name} = \@specific;
+ }
+
+ $self->saved_direct_dependencies(\%dependencies);
+ }
+
+ return $self->saved_direct_dependencies->{$processable->name}
+ if $processable;
+
+ return $self->saved_direct_dependencies;
+}
+
+=item direct_reliants (PROC)
+
+If PROC is a part of the underlying processable group, this method
+returns a listref containing all the packages in the group that rely
+on PROC. If PROC is not a part of the group, this returns undef.
+
+Note: Only strong dependencies (Pre-Depends and Depends) are
+considered.
+
+Note: Self-dependencies (if any) are I<not> included in the result.
+
+=cut
+
+has saved_direct_reliants => (is => 'rw', default => sub { {} });
+
+sub direct_reliants {
+ my ($self, $processable) = @_;
+
+ unless (keys %{$self->saved_direct_reliants}) {
+
+ my @processables = $self->get_installables;
+
+ my %reliants;
+ foreach my $that (@processables) {
+
+ my @specific;
+ foreach my $this (@processables) {
+
+ # Ignore self deps - we have checks for that and it
+ # will just end up complicating "correctness" of
+ # otherwise simple checks.
+ next
+ if $this->name eq $that->name;
+
+ my $relation = $this->relation('strong');
+ push @specific, $this
+ if $relation->satisfies($that->name);
+ }
+ $reliants{$that->name} = \@specific;
+ }
+
+ $self->saved_direct_reliants(\%reliants);
+ }
+
+ return $self->saved_direct_reliants->{$processable->name}
+ if $processable;
+
+ return $self->saved_direct_reliants;
+}
+
+=item spelling_exceptions
+
+Returns a hashref of words, which the spell checker should ignore.
+These words are generally based on the package names in the group to
+avoid false-positive "spelling error" when packages have "fun" names.
+
+Example: Package alot-doc (#687464)
+
+=cut
+
+has spelling_exceptions => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @acceptable;
+
+ # this run may not have all types
+ for my $processable ($self->get_processables) {
+
+ # all processables have those
+ my @package_names= ($processable->name, $processable->source_name);
+
+ # for sources we have d/control
+ push(@package_names, $processable->debian_control->installables)
+ if $processable->type eq 'source';
+
+ push(@acceptable, @package_names);
+
+ # exempt pieces, too
+ my @package_pieces = map { split(m{-}) } @package_names;
+ push(@acceptable, @package_pieces);
+
+ my @people_names;
+ for my $role (qw(Maintainer Uploaders Changed-By)) {
+
+ my $value = $processable->fields->value($role);
+ for my $parsed (Email::Address::XS->parse($value)) {
+
+ push(@people_names, $parsed->phrase)
+ if length $parsed->phrase;
+ }
+ }
+
+ push(@acceptable, @people_names);
+
+ # exempt first and last name separately, too
+ my @people_pieces = map { split($SPACE) } @people_names;
+ push(@acceptable, @people_pieces);
+ }
+
+ return [uniq @acceptable];
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Hint.pm b/lib/Lintian/Hint.pm
new file mode 100644
index 0000000..ee45393
--- /dev/null
+++ b/lib/Lintian/Hint.pm
@@ -0,0 +1,88 @@
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Hint;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Hint -- Common facilities for Lintian tags found and to be issued
+
+=head1 SYNOPSIS
+
+ use Moo;
+ use namespace::clean;
+
+ with 'Lintian::Hint';
+
+=head1 DESCRIPTION
+
+Common facilities for Lintian tags found and to be issued
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item tag_name
+
+=item issued_by
+
+=item override
+
+=item masks
+
+=cut
+
+has tag_name => (is => 'rw', default => $EMPTY);
+has issued_by => (is => 'rw', default => $EMPTY);
+
+has override => (is => 'rw');
+has masks => (is => 'rw', default => sub { [] });
+
+no namespace::clean;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Hint/Annotated.pm b/lib/Lintian/Hint/Annotated.pm
new file mode 100644
index 0000000..137f8fe
--- /dev/null
+++ b/lib/Lintian/Hint/Annotated.pm
@@ -0,0 +1,78 @@
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Hint::Annotated;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Hint';
+
+=head1 NAME
+
+Lintian::Hint::Annotated - standard tag with arguments concatenated by space
+
+=head1 SYNOPSIS
+
+ use Lintian::Hint::Annotated;
+
+=head1 DESCRIPTION
+
+Provides a standard tag whose arguments are concatenated by a space.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item note
+
+=cut
+
+has note => (is => 'rw', default => $EMPTY);
+
+=item context
+
+=cut
+
+sub context {
+ my ($self) = @_;
+
+ return $self->note;
+}
+
+=back
+
+=cut
+
+1;
+
+__END__
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Hint/Pointed.pm b/lib/Lintian/Hint/Pointed.pm
new file mode 100644
index 0000000..be59731
--- /dev/null
+++ b/lib/Lintian/Hint/Pointed.pm
@@ -0,0 +1,88 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Hint::Pointed;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Hint';
+
+=head1 NAME
+
+Lintian::Hint::Pointed - pointed tag with arguments concatenated by space
+
+=head1 SYNOPSIS
+
+ use Lintian::Hint::Pointed;
+
+=head1 DESCRIPTION
+
+Provides a pointed tag whose arguments are concatenated by a space.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item note
+
+=cut
+
+has note => (is => 'rw', default => $EMPTY);
+
+=item pointer
+
+=cut
+
+has pointer => (is => 'rw');
+
+=item context
+
+=cut
+
+sub context {
+ my ($self) = @_;
+
+ my $pointer = $self->pointer->to_string;
+ my @pieces = grep { length } ($self->note, "[$pointer]");
+
+ return join($SPACE, @pieces);
+}
+
+=back
+
+=cut
+
+1;
+
+__END__
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/IO/Select.pm b/lib/Lintian/IO/Select.pm
new file mode 100644
index 0000000..fec6a1e
--- /dev/null
+++ b/lib/Lintian/IO/Select.pm
@@ -0,0 +1,259 @@
+# Hey emacs! This is a -*- Perl -*- script!
+#
+# Lintian::IO::Select -- Perl utility functions for lintian
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::IO::Select;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+our @EXPORT_OK;
+
+BEGIN {
+
+ @EXPORT_OK = qw(
+ unpack_and_index_piped_tar
+ );
+}
+
+use Const::Fast;
+use IPC::Open3;
+use IO::Select;
+use Symbol;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+# read up to 40kB at a time. this happens to be 4096 "tar records"
+# (with a block-size of 512 and a block factor of 20, which appear to
+# be the defaults). when we do full reads and writes of READ_SIZE (the
+# OS willing), the receiving end will never be with an incomplete
+# record.
+const my $TAR_RECORD_SIZE => 20 * 512;
+
+# using 4096 * $TAR_RECORD_SIZE tripped up older kernels < 5.7
+const my $READ_CHUNK => 4 * 1024;
+
+const my $EMPTY => q{};
+
+=head1 NAME
+
+Lintian::IO::Select - process functions based on IO::Select
+
+=head1 SYNOPSIS
+
+ use Lintian::IO::Select;
+
+=head1 DESCRIPTION
+
+This module contains process functions based on IO::Select.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item unpack_and_index_piped_tar
+
+=cut
+
+sub unpack_and_index_piped_tar {
+ my ($command, $basedir) = @_;
+
+ my @pids;
+
+ my $select = IO::Select->new;
+
+ my $produce_stdin;
+ my $produce_stdout;
+ my $produce_stderr = gensym;
+
+ my @produce_command = @{$command};
+
+ my $produce_pid;
+ try {
+ $produce_pid = open3(
+ $produce_stdin, $produce_stdout,
+ $produce_stderr, @produce_command
+ );
+ } catch {
+ die map { encode_utf8($_) } $@;
+ }
+
+ close $produce_stdin;
+
+ push(@pids, $produce_pid);
+
+ $select->add($produce_stdout, $produce_stderr);
+
+ my $extract_stdin;
+ my $extract_stdout;
+ my $extract_stderr = gensym;
+
+ my @extract_command = (
+ qw(tar --no-same-owner --no-same-permissions --touch --extract --file - -C),
+ $basedir
+ );
+
+ my $extract_pid;
+ try {
+ $extract_pid = open3(
+ $extract_stdin, $extract_stdout,
+ $extract_stderr, @extract_command
+ );
+ } catch {
+ die map { encode_utf8($_) } $@;
+ }
+
+ push(@pids, $extract_pid);
+
+ $select->add($extract_stdout, $extract_stderr);
+
+ my @index_options
+ = qw(--list --verbose --utc --full-time --quoting-style=c --file -);
+
+ my $named_stdin;
+ my $named_stdout;
+ my $named_stderr = gensym;
+
+ my @named_command = ('tar', @index_options);
+
+ my $named_pid;
+ try {
+ $named_pid
+ = open3($named_stdin, $named_stdout, $named_stderr, @named_command);
+ } catch {
+ die map { encode_utf8($_) } $@;
+ }
+
+ push(@pids, $named_pid);
+
+ $select->add($named_stdout, $named_stderr);
+
+ my $numeric_stdin;
+ my $numeric_stdout;
+ my $numeric_stderr = gensym;
+
+ my @numeric_command = ('tar', '--numeric-owner', @index_options);
+
+ my $numeric_pid;
+ try {
+ $numeric_pid = open3(
+ $numeric_stdin, $numeric_stdout,
+ $numeric_stderr, @numeric_command
+ );
+ } catch {
+ die map { encode_utf8($_) } $@;
+ }
+
+ push(@pids, $numeric_pid);
+
+ $select->add($numeric_stdout, $numeric_stderr);
+
+ my $named = $EMPTY;
+ my $numeric = $EMPTY;
+
+ my $produce_errors = $EMPTY;
+ my $extract_errors = $EMPTY;
+ my $named_errors = $EMPTY;
+
+ while (my @ready = $select->can_read) {
+
+ for my $handle (@ready) {
+
+ my $buffer;
+ my $length = sysread($handle, $buffer, $READ_CHUNK);
+
+ die encode_utf8("Error from child: $!\n")
+ unless defined $length;
+
+ if ($length == 0){
+ if ($handle == $produce_stdout) {
+ close $extract_stdin;
+ close $named_stdin;
+ close $numeric_stdin;
+ }
+ $select->remove($handle);
+ next;
+ }
+
+ if ($handle == $produce_stdout) {
+ print {$extract_stdin} $buffer;
+ print {$named_stdin} $buffer;
+ print {$numeric_stdin} $buffer;
+
+ } elsif ($handle == $named_stdout) {
+ $named .= $buffer;
+
+ } elsif ($handle == $numeric_stdout) {
+ $numeric .= $buffer;
+
+ } elsif ($handle == $produce_stderr) {
+ $produce_errors .= $buffer;
+
+ } elsif ($handle == $extract_stderr) {
+ $extract_errors .= $buffer;
+
+ } elsif ($handle == $named_stderr) {
+ $named_errors .= $buffer;
+
+ # } else {
+ # die encode_utf8("Shouldn't be here\n");
+ }
+ }
+ }
+
+ close $produce_stdout;
+ close $produce_stderr;
+
+ close $extract_stdout;
+ close $extract_stderr;
+
+ close $named_stdout;
+ close $named_stderr;
+
+ close $numeric_stdout;
+ close $numeric_stderr;
+
+ waitpid($_, 0) for @pids;
+
+ my $tar_errors = ($produce_errors // $EMPTY) . ($extract_errors // $EMPTY);
+ my $index_errors = $named_errors;
+
+ return ($named, $numeric, $tar_errors, $index_errors);
+}
+
+=back
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/IPC/Run3.pm b/lib/Lintian/IPC/Run3.pm
new file mode 100644
index 0000000..e762be5
--- /dev/null
+++ b/lib/Lintian/IPC/Run3.pm
@@ -0,0 +1,135 @@
+# Hey emacs! This is a -*- Perl -*- script!
+#
+# Lintian::IPC::Run3 -- Perl utility functions for lintian
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::IPC::Run3;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+our @EXPORT_OK;
+
+BEGIN {
+
+ @EXPORT_OK = qw(
+ safe_qx
+ xargs
+ );
+}
+
+use Const::Fast;
+use IPC::Run3;
+
+const my $EMPTY => q{};
+const my $NULL => qq{\0};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+=head1 NAME
+
+Lintian::IPC::Run3 - process functions based on IPC::Run3
+
+=head1 SYNOPSIS
+
+ use Lintian::IPC::Run3 qw(safe_qx);
+
+=head1 DESCRIPTION
+
+This module contains process functions based on IPC::Run3.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<safe_qx(@cmd)>
+
+Emulates the C<qx()> operator but with array argument only.
+
+=cut
+
+sub safe_qx {
+ my @command = @_;
+
+ my $stdout;
+ my $stderr;
+
+ run3(\@command, \undef, \$stdout, \$stderr);
+
+ my $exitcode = $?;
+ my $status = ($exitcode >> $WAIT_STATUS_SHIFT);
+
+ $? = $status;
+
+ return $stdout . $stderr
+ if $?;
+
+ return $stdout;
+}
+
+=item C<xargs>
+
+=cut
+
+sub xargs {
+ my ($command, $arguments, $processor) = @_;
+
+ $command //= [];
+ $arguments //= [];
+
+ return
+ unless @{$arguments};
+
+ my $input = $EMPTY;
+ $input .= $_ . $NULL for @{$arguments};
+
+ my $stdout;
+ my $stderr;
+
+ my @combined = (qw(xargs --null --no-run-if-empty), @{$command});
+
+ run3(\@combined, \$input, \$stdout, \$stderr);
+
+ my $exitcode = $?;
+ my $status = ($exitcode >> $WAIT_STATUS_SHIFT);
+
+ $processor->($stdout, $stderr, $status, @{$arguments});
+
+ return;
+}
+
+=back
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Index.pm b/lib/Lintian/Index.pm
new file mode 100644
index 0000000..b442455
--- /dev/null
+++ b/lib/Lintian/Index.pm
@@ -0,0 +1,878 @@
+# -*- perl -*- Lintian::Index
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp;
+use Const::Fast;
+use Cwd;
+use IPC::Run3;
+use List::SomeUtils qw(any);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+use Lintian::Index::Item;
+use Lintian::IO::Select qw(unpack_and_index_piped_tar);
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Lintian::Util qw(perm2oct);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $BACKSLASH => q{\\};
+const my $ZERO => q{0};
+const my $HYPHEN => q{-};
+const my $PERCENT => q{%};
+const my $NEWLINE => qq{\n};
+
+const my $WAIT_STATUS_SHIFT => 8;
+const my $NO_LIMIT => -1;
+const my $LINES_PER_FILE => 3;
+const my $WIDELY_READABLE_FOLDER => oct(755);
+const my $WORLD_WRITABLE_FOLDER => oct(777);
+
+use Moo;
+use namespace::clean;
+
+with
+ 'Lintian::Index::Ar',
+ 'Lintian::Index::Elf',
+ 'Lintian::Index::FileTypes',
+ 'Lintian::Index::Java',
+ 'Lintian::Index::Md5sums',
+ 'Lintian::Index::Strings';
+
+my %FILE_CODE2LPATH_TYPE = (
+ $HYPHEN => Lintian::Index::Item::TYPE_FILE
+ | Lintian::Index::Item::OPEN_IS_OK,
+ 'h' => Lintian::Index::Item::TYPE_HARDLINK
+ | Lintian::Index::Item::OPEN_IS_OK,
+ 'd' => Lintian::Index::Item::TYPE_DIR| Lintian::Index::Item::FS_PATH_IS_OK,
+ 'l' => Lintian::Index::Item::TYPE_SYMLINK,
+ 'b' => Lintian::Index::Item::TYPE_BLOCK_DEV,
+ 'c' => Lintian::Index::Item::TYPE_CHAR_DEV,
+ 'p' => Lintian::Index::Item::TYPE_PIPE,
+);
+
+=head1 NAME
+
+Lintian::Index - access to collected data about the upstream (orig) sources
+
+=head1 SYNOPSIS
+
+ use Lintian::Index;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Orig::Index provides an interface to collected data about the upstream (orig) sources.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item identifier
+
+=item catalog
+
+Returns a reference to a hash with elements catalogued by path names.
+
+=item C<basedir>
+
+Returns the base directory for file references.
+
+=item C<anchored>
+
+=item unpack_messages
+
+=cut
+
+has identifier => (is => 'rw', default => 'unnamed');
+
+has catalog => (
+ is => 'rw',
+ default => sub {
+ my ($self) = @_;
+
+ # create an empty root
+ my $root = Lintian::Index::Item->new;
+
+ # associate with this index
+ $root->index($self);
+
+ my %catalog;
+ $catalog{$EMPTY} = $root;
+
+ return \%catalog;
+ }
+);
+
+has basedir => (
+ is => 'rw',
+ trigger => sub {
+ my ($self, $folder) = @_;
+
+ return
+ unless length $folder;
+
+ # create directory
+ path($folder)->mkpath({ chmod => $WORLD_WRITABLE_FOLDER })
+ unless -e $folder;
+ },
+ default => $EMPTY
+);
+
+has anchored => (is => 'rw', default => 0);
+has unpack_messages => (is => 'rw', default => sub { [] });
+
+has sorted_list => (
+ is => 'ro',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @sorted = sort { $a->name cmp $b->name } values %{$self->catalog};
+
+ # remove automatic root dir; list is sorted
+ shift @sorted;
+
+ const my @IMMUTABLE => @sorted;
+
+ return \@IMMUTABLE;
+ }
+);
+
+=item lookup (FILE)
+
+Like L</index> except orig_index is based on the "orig tarballs" of
+the source packages.
+
+For native packages L</index> and L</orig_index> are generally
+identical.
+
+NB: If sorted_index includes a debian packaging, it is was
+contained in upstream part of the source package (or the package is
+native).
+
+=cut
+
+sub lookup {
+ my ($self, $name) = @_;
+
+ # get root dir by default
+ $name //= $EMPTY;
+
+ croak encode_utf8($self->identifier . ': Name is not a string')
+ unless ref $name eq $EMPTY;
+
+ my $found = $self->catalog->{$name};
+
+ return $found
+ if defined $found;
+
+ return undef;
+}
+
+=item resolve_path
+
+=cut
+
+sub resolve_path {
+ my ($self, $name) = @_;
+
+ return $self->lookup->resolve_path($name);
+}
+
+=item create_from_basedir
+
+=cut
+
+sub create_from_basedir {
+ my ($self) = @_;
+
+ my $savedir = getcwd;
+ chdir($self->basedir)
+ or die encode_utf8(
+ $self->identifier . ': Cannot change to directory ' . $self->basedir);
+
+ # get times in UTC
+ my $TIME_STAMP
+ = $PERCENT . q{M} . $SPACE . $PERCENT . q{s} . $SPACE . $PERCENT . q{A+};
+ my $FILE_NAME = $PERCENT . q{p};
+ my $LINK_DESTINATION = $PERCENT . q{l};
+ my $NULL_BREAK = $BACKSLASH . $ZERO;
+
+ my @REQUESTED_FIELDS
+ = map { $_ . $NULL_BREAK } ($TIME_STAMP, $FILE_NAME, $LINK_DESTINATION);
+
+ my @index_command
+ = ('env', 'TZ=UTC', 'find', '-printf', join($EMPTY, @REQUESTED_FIELDS));
+ my $index_output;
+ my $index_errors;
+
+ run3(\@index_command, \undef, \$index_output, \$index_errors);
+
+ chdir($savedir)
+ or die encode_utf8(
+ $self->identifier . ": Cannot change to directory $savedir");
+
+ # allow processing of file names with non UTF-8 bytes
+ $index_errors = decode_utf8($index_errors)
+ if length $index_errors;
+
+ my $permissionspattern = qr/\S{10}/;
+ my $sizepattern = qr/\d+/;
+ my $datepattern = qr/\d{4}-\d{2}-\d{2}/;
+ my $timepattern = qr/\d{2}:\d{2}:\d{2}\.\d+/;
+ my $pathpattern = qr/[^\0]*/;
+
+ my %all;
+
+ $index_output =~ s/\0$//;
+
+ my @lines = split(/\0/, $index_output, $NO_LIMIT);
+ die encode_utf8($self->identifier
+ . ": Did not get a multiple of $LINES_PER_FILE lines from find.")
+ unless @lines % $LINES_PER_FILE == 0;
+
+ while (defined(my $first = shift @lines)) {
+
+ my $entry = Lintian::Index::Item->new;
+ $entry->index($self);
+
+ $first
+ =~ /^($permissionspattern)\ ($sizepattern)\ ($datepattern)\+($timepattern)$/s;
+
+ $entry->perm($1);
+ $entry->size($2);
+ $entry->date($3);
+ $entry->time($4);
+
+ my $name = shift @lines;
+
+ my $linktarget = shift @lines;
+
+ # for non-links, string is empty
+ $entry->link($linktarget)
+ if length $linktarget;
+
+ # find prints single dot for base; removed in next step
+ $name =~ s{^\.$}{\./}s;
+
+ # strip relative prefix
+ $name =~ s{^\./+}{}s;
+
+ # make sure directories end with a slash, except root
+ $name .= $SLASH
+ if length $name
+ && $entry->perm =~ /^d/
+ && $name !~ m{ /$ }msx;
+ $entry->name($name);
+
+ $all{$entry->name} = $entry;
+ }
+
+ $self->catalog(\%all);
+
+ my $load_errors = $self->load;
+
+ return $index_errors . $load_errors;
+}
+
+=item create_from_piped_tar
+
+=cut
+
+sub create_from_piped_tar {
+ my ($self, $command) = @_;
+
+ my $extract_dir = $self->basedir;
+
+ my ($named, $numeric, $extract_errors, $index_errors)
+ = unpack_and_index_piped_tar($command, $extract_dir);
+
+ # fix permissions
+ safe_qx('chmod', '-R', 'u+rwX,go-w', $extract_dir);
+
+ # allow processing of file names with non UTF-8 bytes
+ my @named_owner = split(/\n/, $named);
+ my @numeric_owner = split(/\n/, $numeric);
+
+ my %catalog;
+
+ for my $line (@named_owner) {
+
+ my $entry = Lintian::Index::Item->new;
+ $entry->init_from_tar_output($line);
+ $entry->index($self);
+
+ $catalog{$entry->name} = $entry;
+ }
+
+ # get numerical owners from second list
+ for my $line (@numeric_owner) {
+
+ # entry not used outside this loop
+ my $entry = Lintian::Index::Item->new;
+ $entry->init_from_tar_output($line);
+
+ die encode_utf8($self->identifier
+ . ': Numerical index lists extra files for file name '
+ . $entry->name)
+ unless exists $catalog{$entry->name};
+
+ # keep numerical uid and gid
+ $catalog{$entry->name}->uid($entry->owner);
+ $catalog{$entry->name}->gid($entry->group);
+ }
+
+ # tar produces spurious root entry when stripping slashes from member names
+ delete $catalog{$SLASH}
+ unless $self->anchored;
+
+ $self->catalog(\%catalog);
+
+ my $load_errors = $self->load;
+
+ return $extract_errors . $index_errors . $load_errors;
+}
+
+=item load
+
+=cut
+
+sub load {
+ my ($self) = @_;
+
+ my $errors = $EMPTY;
+
+ my %all = %{$self->catalog};
+
+ # set internal permissions flags
+ for my $entry (values %all) {
+
+ my $raw_type = substr($entry->perm, 0, 1);
+
+ my $operm = perm2oct($entry->perm);
+ $entry->path_info(
+ $operm | (
+ $FILE_CODE2LPATH_TYPE{$raw_type}
+ // Lintian::Index::Item::TYPE_OTHER
+ )
+ );
+ }
+
+ # find all entries that are not regular files
+ my @nosize
+ = grep { !$_->path_info & Lintian::Index::Item::TYPE_FILE } values %all;
+
+ # reset size for anything but regular files
+ $_->size(0) for @nosize;
+
+ if ($self->anchored) {
+
+ my %relative;
+ for my $name (keys %all) {
+ my $entry = $all{$name};
+
+ # remove leading slash from absolute names
+ my $name = $entry->name;
+ $name =~ s{^/+}{}s;
+ $entry->name($name);
+
+ # remove leading slash from absolute hardlink targets
+ if ($entry->is_hardlink) {
+ my $target = $entry->link;
+ $target =~ s{^/+}{}s;
+ $entry->link($target);
+ }
+
+ $relative{$name} = $entry;
+ }
+
+ %all = %relative;
+ }
+
+ # disallow absolute names
+ die encode_utf8($self->identifier . ': Index contains absolute path names')
+ if any { $_->name =~ m{^/}s } values %all;
+
+ # disallow absolute hardlink targets
+ die encode_utf8(
+ $self->identifier . ': Index contains absolute hardlink targets')
+ if any { $_->link =~ m{^/}s } grep { $_->is_hardlink } values %all;
+
+ # add entries for missing directories
+ for my $entry (values %all) {
+
+ my $current = $entry;
+ my $parentname;
+
+ # travel up the directory tree
+ do {
+ $parentname = $current->dirname;
+
+ # insert new entry for missing intermediate directories
+ unless (exists $all{$parentname}) {
+
+ my $added = Lintian::Index::Item->new;
+ $added->index($self);
+
+ $added->name($parentname);
+ $added->path_info(
+ $FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER);
+
+ # random but fixed date; hint, it's a good read. :)
+ $added->date('1998-01-25');
+ $added->time('22:55:34');
+ $added->faux(1);
+
+ $all{$parentname} = $added;
+ }
+
+ $current = $all{$parentname};
+
+ } while ($parentname ne $EMPTY);
+ }
+
+ # insert root for empty tarfies like suckless-tools_45.orig.tar.xz
+ unless (exists $all{$EMPTY}) {
+
+ my $root = Lintian::Index::Item->new;
+ $root->index($self);
+
+ $root->name($EMPTY);
+ $root->path_info($FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER);
+
+ # random but fixed date; hint, it's a good read. :)
+ $root->date('1998-01-25');
+ $root->time('22:55:34');
+ $root->faux(1);
+
+ $all{$EMPTY} = $root;
+ }
+
+ my @directories
+ = grep { $_->path_info & Lintian::Index::Item::TYPE_DIR } values %all;
+
+ # make space for children
+ my %children;
+ $children{$_->name} = [] for @directories;
+
+ # record children
+ for my $entry (values %all) {
+
+ my $parentname = $entry->dirname;
+
+ # Ensure the "root" is not its own child. It is not really helpful
+ # from an analysis PoV and it creates ref cycles (and by extension
+ # leaks like #695866).
+ push(@{ $children{$parentname} }, $entry)
+ unless $parentname eq $entry->name;
+ }
+
+ foreach my $entry (@directories) {
+ my %childnames
+ = map {$_->basename => $_->name }@{ $children{$entry->name} };
+ $entry->childnames(\%childnames);
+ }
+
+ # ensure root is not its own child; may create leaks like #695866
+ die encode_utf8($self->identifier . ': Root directory is its own parent')
+ if defined $all{$EMPTY} && defined $all{$EMPTY}->parent_dir;
+
+ # find all hard links
+ my @hardlinks
+ = grep { $_->path_info & Lintian::Index::Item::TYPE_HARDLINK }
+ values %all;
+
+ # catalog where they point
+ my %backlinks;
+ push(@{$backlinks{$_->link}}, $_) for @hardlinks;
+
+ # add the master files for proper sort results
+ push(@{$backlinks{$_}}, $all{$_}) for keys %backlinks;
+
+ # point hard links to shortest path
+ for my $mastername (keys %backlinks) {
+
+ my @group = @{$backlinks{$mastername}};
+
+ # sort for path length
+ my @links = sort { $a->name cmp $b->name } @group;
+
+ # pick the shortest path
+ my $preferred = shift @links;
+
+ # get the previous master entry
+ my $master = $all{$mastername};
+
+ # skip if done
+ next
+ if $preferred->name eq $master->name;
+
+ # unset link for preferred
+ $preferred->link($EMPTY);
+
+ # copy size from original
+ $preferred->size($master->size);
+
+ $preferred->path_info(
+ ($preferred->path_info& ~Lintian::Index::Item::TYPE_HARDLINK)
+ | Lintian::Index::Item::TYPE_FILE);
+
+ foreach my $pointer (@links) {
+
+ # turn into a hard link
+ $pointer->path_info(
+ ($pointer->path_info & ~Lintian::Index::Item::TYPE_FILE)
+ | Lintian::Index::Item::TYPE_HARDLINK);
+
+ # set link to preferred path
+ $pointer->link($preferred->name);
+
+ # no size for hardlinks
+ $pointer->size(0);
+ }
+ }
+
+ # make sure recorded names match hash keys
+ $all{$_}->name($_) for keys %all;
+
+ $self->catalog(\%all);
+
+ $errors .= $self->add_md5sums;
+ $errors .= $self->add_file_types;
+
+ $errors .= $self->add_ar;
+ $errors .= $self->add_elf;
+ $errors .= $self->add_java;
+ $errors .= $self->add_strings;
+
+ return $errors;
+}
+
+=item merge_in
+
+=cut
+
+sub merge_in {
+ my ($self, $other) = @_;
+
+ die encode_utf8($self->identifier
+ . ': Need same base directory ('
+ . $self->basedir . ' vs '
+ . $other->basedir . ')')
+ unless $self->basedir eq $other->basedir;
+
+ die encode_utf8($self->identifier . ': Need same anchoring status')
+ unless $self->anchored == $other->anchored;
+
+ # associate all new items with this index
+ $_->index($self) for values %{$other->catalog};
+
+ for my $item (values %{$other->catalog}) {
+
+ # do not transfer root
+ next
+ if $item->name eq $EMPTY;
+
+ # duplicates on disk are dropped with basedir segments
+ $self->catalog->{$item->name} = $item;
+
+ # when adding folder, delete potential file entry
+ my $noslash = $item->name;
+ if ($noslash =~ s{/$}{}) {
+ delete $self->catalog->{$noslash};
+ }
+ }
+
+ # add children that came from other root to current
+ my @other_childnames = keys %{$other->catalog->{$EMPTY}->childnames};
+ for my $name (@other_childnames) {
+
+ $self->catalog->{$EMPTY}->childnames->{$name}
+ = $self->catalog->{$name};
+ }
+
+ # remove items from other index
+ $other->catalog({});
+
+ # unset other base directory
+ $other->basedir($EMPTY);
+
+ return;
+}
+
+=item capture_common_prefix
+
+=cut
+
+sub capture_common_prefix {
+ my ($self) = @_;
+
+ my $new_basedir = path($self->basedir)->parent;
+
+ # do nothing in root
+ return
+ if $new_basedir eq $SLASH;
+
+ my $segment = path($self->basedir)->basename;
+ die encode_utf8($self->identifier . ': Common path segment has no length')
+ unless length $segment;
+
+ my $prefix;
+ if ($self->anchored) {
+ $prefix = $SLASH . $segment;
+ } else {
+ $prefix = $segment . $SLASH;
+ }
+
+ my $new_root = Lintian::Index::Item->new;
+
+ # associate new item with this index
+ $new_root->index($self);
+
+ $new_root->name($EMPTY);
+ $new_root->childnames({ $segment => $prefix });
+
+ # random but fixed date; hint, it's a good read. :)
+ $new_root->date('1998-01-25');
+ $new_root->time('22:55:34');
+ $new_root->path_info($FILE_CODE2LPATH_TYPE{'d'} | $WIDELY_READABLE_FOLDER);
+ $new_root->faux(1);
+
+ my %new_catalog;
+ for my $item (values %{$self->catalog}) {
+
+ # drop common prefix from name
+ my $new_name = $prefix . $item->name;
+ $item->name($new_name);
+
+ if (length $item->link) {
+
+ # add common prefix from link target
+ my $new_link = $prefix . $item->link;
+ $item->link($new_link);
+ }
+
+ # adjust references to children
+ for my $basename (keys %{$item->childnames}) {
+ $item->childnames->{$basename}
+ = $prefix . $item->childnames->{$basename};
+ }
+
+ $new_catalog{$new_name} = $item;
+ }
+
+ $new_catalog{$EMPTY} = $new_root;
+ $new_catalog{$prefix}->parent_dir($new_root);
+
+ $self->catalog(\%new_catalog);
+
+ # remove segment from base directory
+ $self->basedir($new_basedir);
+
+ return;
+}
+
+=item drop_common_prefix
+
+=cut
+
+sub drop_common_prefix {
+ my ($self) = @_;
+
+ my $errors = $EMPTY;
+
+ my @childnames = keys %{$self->catalog->{$EMPTY}->childnames};
+
+ die encode_utf8($self->identifier . ': Not exactly one top-level child')
+ unless @childnames == 1;
+
+ my $segment = $childnames[0];
+ die encode_utf8($self->identifier . ': Common path segment has no length')
+ unless length $segment;
+
+ my $new_root = $self->lookup($segment . $SLASH);
+ die encode_utf8($self->identifier . ': New root is not a directory')
+ unless $new_root->is_dir;
+
+ my $prefix;
+ if ($self->anchored) {
+ $prefix = $SLASH . $segment;
+ } else {
+ $prefix = $segment . $SLASH;
+ }
+
+ my $regex = quotemeta($prefix);
+
+ delete $self->catalog->{$EMPTY};
+
+ my %new_catalog;
+ for my $item (values %{$self->catalog}) {
+
+ # drop common prefix from name
+ my $new_name = $item->name;
+ $new_name =~ s{^$regex}{};
+ $item->name($new_name);
+
+ if (length $item->link) {
+
+ # drop common prefix from link target
+ my $new_link = $item->link;
+ $new_link =~ s{^$regex}{};
+ $item->link($new_link);
+ }
+
+ # adjust references to children
+ for my $basename (keys %{$item->childnames}) {
+ $item->childnames->{$basename} =~ s{^$regex}{};
+ }
+
+ # unsure this works, but orig not anchored
+ $new_name = $EMPTY
+ if $new_name eq $SLASH && $self->anchored;
+
+ $new_catalog{$new_name} = $item;
+ }
+
+ $self->catalog(\%new_catalog);
+
+ # add dropped segment to base directory
+ $self->basedir($self->basedir . $SLASH . $segment);
+
+ my $other_errors = $self->drop_basedir_segment;
+
+ return $errors . $other_errors;
+}
+
+=item drop_basedir_segment
+
+=cut
+
+sub drop_basedir_segment {
+ my ($self) = @_;
+
+ my $errors = $EMPTY;
+
+ my $obsolete = path($self->basedir)->basename;
+ die encode_utf8($self->identifier . ': Base directory has no name')
+ unless length $obsolete;
+
+ my $parent_dir = path($self->basedir)->parent->stringify;
+ die encode_utf8($self->identifier . ': Base directory has no parent')
+ if $parent_dir eq $SLASH;
+
+ my $grandparent_dir = path($parent_dir)->parent->stringify;
+ die encode_utf8(
+ $self->identifier . ': Will not do anything in file system root')
+ if $grandparent_dir eq $SLASH;
+
+ # destroyed when object is lost
+ my $tempdir_tiny
+ = path($grandparent_dir)->tempdir(TEMPLATE => 'customXXXXXXXX');
+
+ my $tempdir = $tempdir_tiny->stringify;
+
+ # avoids conflict in case of repeating path segments
+ for my $child (path($self->basedir)->children) {
+ my $old_name = $child->stringify;
+
+ # Perl unicode bug
+ utf8::downgrade $old_name;
+ utf8::downgrade $tempdir;
+
+ my @command = ('mv', $old_name, $tempdir);
+ my $stderr;
+ run3(\@command, \undef, \undef, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # already in UTF-8
+ die $stderr
+ if $status;
+ }
+
+ rmdir $self->basedir;
+ $self->basedir($parent_dir);
+
+ for my $child ($tempdir_tiny->children) {
+ my $old_name = $child->stringify;
+
+ my $target_dir = $parent_dir . $SLASH . $child->basename;
+
+ # Perl unicode bug
+ utf8::downgrade $target_dir;
+
+ if (-e $target_dir) {
+
+ # catalog items were dropped when index was merged
+ my @command = (qw{rm -rf}, $target_dir);
+ my $stderr;
+ run3(\@command, \undef, \undef, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # already in UTF-8
+ die $stderr
+ if $status;
+
+ my $display_dir
+ = path($parent_dir)->basename . $SLASH . $child->basename;
+ $errors .= "removed existing $display_dir" . $NEWLINE;
+ }
+
+ # Perl unicode bug
+ utf8::downgrade $old_name;
+ utf8::downgrade $parent_dir;
+
+ my @command = ('mv', $old_name, $parent_dir);
+ my $stderr;
+ run3(\@command, \undef, \undef, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ # already in UTF-8
+ die $stderr
+ if $status;
+ }
+
+ return $errors;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Index/Ar.pm b/lib/Lintian/Index/Ar.pm
new file mode 100644
index 0000000..01f3e6b
--- /dev/null
+++ b/lib/Lintian/Index/Ar.pm
@@ -0,0 +1,128 @@
+# -*- perl -*- Lintian::Index::Ar
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index::Ar;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd;
+use Path::Tiny;
+use Unicode::UTF8 qw(decode_utf8 encode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $NEWLINE => qq{\n};
+
+=head1 NAME
+
+Lintian::Index::Ar - binary symbol information.
+
+=head1 SYNOPSIS
+
+ use Lintian::Index;
+
+=head1 DESCRIPTION
+
+Lintian::Index::Ar binary symbol information.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item add_ar
+
+=cut
+
+sub add_ar {
+ my ($self) = @_;
+
+ my $savedir = getcwd;
+ chdir($self->basedir)
+ or die encode_utf8(
+ $self->identifier . ': Cannot change to directory ' . $self->basedir);
+
+ my $errors = $EMPTY;
+
+ my @archives
+ = grep { $_->name =~ / [.]a $/msx && $_->is_regular_file }
+ @{$self->sorted_list};
+
+ for my $archive (@archives) {
+
+ # skip empty archives to avoid ar error message; happens in tests
+ next
+ unless $archive->size;
+
+ my %ar_info;
+
+ # fails silently for non-ar files (#934899); probably creates empty entries
+ my $bytes = safe_qx(qw{ar t}, $archive);
+ if ($?) {
+ $errors .= "ar failed for $archive" . $NEWLINE;
+ next;
+ }
+
+ my $output = decode_utf8($bytes);
+ my @members = split(/\n/, $output);
+
+ my $count = 1;
+ for my $member (@members) {
+
+ # more info could be added with -v above
+ $ar_info{$count}{name} = $member;
+
+ } continue {
+ $count++;
+ }
+
+ $archive->ar_info(\%ar_info);
+ }
+
+ chdir($savedir)
+ or die encode_utf8(
+ $self->identifier . ": Cannot change to directory $savedir");
+
+ return $errors;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Index/Elf.pm b/lib/Lintian/Index/Elf.pm
new file mode 100644
index 0000000..1fe4d7a
--- /dev/null
+++ b/lib/Lintian/Index/Elf.pm
@@ -0,0 +1,739 @@
+# -*- perl -*- Lintian::Index::Elf
+#
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2008 Adam D. Barratt
+# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2022 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index::Elf;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use bignum qw(hex);
+
+use Const::Fast;
+use Cwd;
+use IPC::Run3;
+use Unicode::UTF8 qw(encode_utf8 valid_utf8 decode_utf8);
+
+use Lintian::Elf::Section;
+use Lintian::Elf::Symbol;
+use Lintian::Storage::MLDBM;
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $HYPHEN => q{-};
+const my $NEWLINE => qq{\n};
+
+const my $LINES_PER_FILE => 3;
+
+=head1 NAME
+
+Lintian::Index::Elf - binary symbol information.
+
+=head1 SYNOPSIS
+
+ use Lintian::Index;
+
+=head1 DESCRIPTION
+
+Lintian::Index::Elf binary symbol information.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item elf_storage
+
+=cut
+
+has elf_storage => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $storage = Lintian::Storage::MLDBM->new;
+ $storage->create('elf');
+
+ return $storage;
+ }
+);
+
+=item elf_storage_by_member
+
+=cut
+
+has elf_storage_by_member => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $storage = Lintian::Storage::MLDBM->new;
+ $storage->create('elf-by-member');
+
+ return $storage;
+ }
+);
+
+=item add_elf
+
+=cut
+
+sub add_elf {
+ my ($self) = @_;
+
+ my $savedir = getcwd;
+ chdir($self->basedir)
+ or die encode_utf8(
+ $self->identifier . ': Cannot change to directory ' . $self->basedir);
+
+ my $errors = $EMPTY;
+
+ my @files = grep { $_->is_file } @{$self->sorted_list};
+
+ # must be ELF or static library
+ my @with_objects = grep {
+ $_->file_type =~ /\bELF\b/
+ || ( $_->file_type =~ /\bcurrent ar archive\b/
+ && $_->name =~ /\.a$/)
+ } @files;
+
+ for my $file (@with_objects) {
+
+ local $SIG{__WARN__}= sub {
+ warn encode_utf8($self->identifier
+ . ': Warning while running readelf on'
+ . $file->name
+ . ": $_[0]");
+ };
+
+ my @command = (qw{readelf --all --wide}, $file->name);
+ my $combined_bytes;
+
+ run3(\@command, \undef, \$combined_bytes, \$combined_bytes);
+
+ next
+ unless length $combined_bytes;
+
+ my $combined_output;
+
+ if (valid_utf8($combined_bytes)) {
+ $combined_output = decode_utf8($combined_bytes);
+
+ } else {
+ $combined_output = $combined_bytes;
+ $errors .= "Output from '@command' is not valid UTF-8" . $NEWLINE;
+ }
+
+ # each object file in an archive gets its own File section
+ my @per_files = split(/^(File): (.*)$/m, $combined_output);
+ shift @per_files while @per_files && $per_files[0] ne 'File';
+
+ @per_files = ($combined_output)
+ unless @per_files;
+
+ # Special case - readelf will not prefix the output with "File:
+ # $name" if it only gets one ELF file argument, so act as if it did...
+ # (but it does "the right thing" if passed a static lib >.>)
+ #
+ # - In fact, if readelf always emitted that File: header, we could
+ # simply use xargs directly on readelf and just parse its output
+ # in the loop below.
+ if (@per_files == 1) {
+ unshift(@per_files, $file->name);
+ unshift(@per_files, 'File');
+ }
+
+ unless (@per_files % $LINES_PER_FILE == 0) {
+
+ $errors
+ .= "Parsed data from readelf is not a multiple of $LINES_PER_FILE for $file"
+ . $NEWLINE;
+ next;
+ }
+
+ while (defined(my $fixed = shift @per_files)) {
+
+ my $recorded_name = shift @per_files;
+ my $per_file = shift @per_files;
+
+ unless ($fixed eq 'File') {
+ $errors .= "Unknown output from readelf for $file" . $NEWLINE;
+ next;
+ }
+
+ unless (length $recorded_name) {
+ $errors .= "No file name from readelf for $file" . $NEWLINE;
+ next;
+ }
+
+ my ($container, $member) = ($recorded_name =~ /^(.*)\(([^)]+)\)$/);
+
+ $container = $recorded_name
+ unless defined $container && defined $member;
+
+ unless ($container eq $file->name) {
+ $errors
+ .= "Container not same as file name ($container vs $file)"
+ . $NEWLINE;
+ next;
+ }
+
+ # ignore empty archives, such as in musl-dev_1.2.1-1_amd64.deb
+ next
+ unless length $per_file;
+
+ my $object_name;
+ if ($recorded_name =~ m{^(?:.+)\(([^/\)]+)\)$}){
+
+ # object file in a static lib.
+ $object_name = $1;
+ }
+
+ parse_per_file($file, $object_name, $per_file);
+ }
+ }
+
+ chdir($savedir)
+ or die encode_utf8(
+ $self->identifier . ": Cannot change to directory $savedir");
+
+ return $errors;
+}
+
+=item parse_per_file
+
+=cut
+
+sub parse_per_file {
+ my ($file, $object_name, $from_readelf) = @_;
+
+ my %by_object;
+
+ $by_object{READELF} = $from_readelf;
+
+ # sometimes there are three blank lines; seen on armhf
+ my @paragraphs = split(/\n{2,}/, $from_readelf);
+
+ for my $paragraph (@paragraphs) {
+
+ my ($first, $bulk) = split(m{\n}, $paragraph, 2);
+
+ if ($first =~ /^ELF Header:/) {
+ elf_header($bulk, \%by_object);
+ next;
+ }
+
+ if ($first =~ /^Program Headers:/) {
+ program_headers($bulk, \%by_object);
+ next;
+ }
+
+ if ($first =~ /^Dynamic section at offset .*:/) {
+ dynamic_section($bulk, \%by_object);
+ next;
+ }
+
+ if ($first =~ /^Section Headers:/) {
+ section_headers($bulk, \%by_object);
+ next;
+ }
+
+ if ($first =~ /^Symbol table '.dynsym'/) {
+ symbol_table($bulk, \%by_object);
+ next;
+ }
+
+ if ($first =~ /^Version symbols section /) {
+ version_symbols($bulk, \%by_object);
+ next;
+ }
+
+ if ($first =~ /^There is no dynamic section in this file/) {
+ # a dynamic section was declared but it's empty.
+ $by_object{'BAD-DYNAMIC-TABLE'} = 1
+ if exists $by_object{PH}{DYNAMIC};
+ next;
+ }
+ }
+
+ my %section_name_by_number;
+ for my $name (keys %{$by_object{SH} // {}}) {
+
+ my $number = $by_object{SH}{$name}{number};
+ $section_name_by_number{$number} = $name;
+ }
+
+ for my $symbol_number (keys %{$by_object{'DYNAMIC-SYMBOLS'}}) {
+
+ my $symbol_name
+ = $by_object{'DYNAMIC-SYMBOLS'}{$symbol_number}{symbol_name};
+ my $section_number
+ = $by_object{'DYNAMIC-SYMBOLS'}{$symbol_number}{section_number};
+
+ my $symbol_version;
+
+ if ($symbol_name =~ m{^ (.*) @ (.*) \s [(] .* [)] $}x) {
+
+ $symbol_name = $1;
+ $symbol_version = $2;
+
+ } else {
+ $symbol_version = $by_object{'SYMBOL-VERSIONS'}{$symbol_number}
+ // $EMPTY;
+
+ if ( $symbol_version eq '*local*'
+ || $symbol_version eq '*global*'){
+
+ if ($section_number eq 'UND') {
+ $symbol_version = $EMPTY;
+
+ } else {
+ $symbol_version = 'Base';
+ }
+
+ } elsif ($symbol_version eq '()') {
+ $symbol_version = '(Base)';
+ }
+ }
+
+ # happens once or twice for regular binaries
+ next
+ unless length $symbol_name;
+
+ # look up numbered section
+ my $section_name = $section_name_by_number{$section_number}
+ // $section_number;
+
+ my $symbol = Lintian::Elf::Symbol->new;
+ $symbol->section($section_name);
+ $symbol->version($symbol_version);
+ $symbol->name($symbol_name);
+
+ push(@{ $by_object{SYMBOLS} }, $symbol);
+ }
+
+ if (length $object_name) {
+
+ # object file in a static lib.
+ $file->elf_by_member($object_name, \%by_object);
+
+ } else {
+ $file->elf(\%by_object);
+ }
+
+ return;
+}
+
+=item elf_header
+
+=cut
+
+sub elf_header {
+ my ($text, $by_object) = @_;
+
+ my @lines = split(m{\n}, $text);
+
+ for my $line (@lines) {
+
+ next
+ if divert_error('ELF header', $line, $by_object);
+
+ my ($field, $value) = split(/:/, $line, 2);
+
+ # trim both ends
+ $field =~ s/^\s+|\s+$//g;
+ $value =~ s/^\s+|\s+$//g;
+
+ next
+ unless length $field && length $value;
+
+ $by_object->{'ELF-HEADER'}{$field} = $value;
+ }
+
+ return;
+}
+
+=item program_headers
+
+=cut
+
+sub program_headers {
+ my ($text, $by_object) = @_;
+
+ my @lines = split(m{\n}, $text);
+
+ while (defined(my $line = shift @lines)) {
+
+ next
+ if divert_error('program headers', $line, $by_object);
+
+ if ($line =~ m{^ \s* (\S+) \s* (?:(?:\S+\s+){4}) \S+ \s (...) }x) {
+
+ my $header = $1;
+ my $flags = $2;
+
+ $header =~ s/^GNU_//g;
+
+ next
+ if $header eq 'Type';
+
+ my $newflags = $EMPTY;
+ $newflags .= ($flags =~ /R/) ? 'r' : $HYPHEN;
+ $newflags .= ($flags =~ /W/) ? 'w' : $HYPHEN;
+ $newflags .= ($flags =~ /E/) ? 'x' : $HYPHEN;
+
+ $by_object->{PH}{$header}{flags} = $newflags;
+
+ if ($header eq 'INTERP' && @lines) {
+ # Check if the next line is the "requesting an interpreter"
+ # (readelf appears to always emit on the next line if at all)
+ my $next_line = $lines[0];
+
+ if ($next_line
+ =~ m{ [[] Requesting \s program \s interpreter: \s ([^\]]+) []] }x
+ ){
+
+ my $interpreter = $1;
+
+ $by_object->{INTERP} = $interpreter;
+
+ # discard line
+ shift @lines;
+ }
+ }
+ }
+ }
+
+ return;
+}
+
+=item dynamic_section
+
+=cut
+
+sub dynamic_section {
+ my ($text, $by_object) = @_;
+
+ my @lines = split(m{\n}, $text);
+
+ while (defined(my $line = shift @lines)) {
+
+ next
+ if divert_error('dynamic section', $line, $by_object);
+
+ if ($line
+ =~ m{^ \s* 0x (?:[0-9A-F]+) \s+ [(] (.*?) [)] \s+ ([\x21-\x7f][\x20-\x7f]*) \Z}ix
+ ) {
+
+ my $type = $1;
+ my $remainder = $2;
+
+ my $keep = 0;
+
+ if ($type eq 'RPATH' || $type eq 'RUNPATH') {
+ $remainder =~ s{^ .* [[] }{}x;
+ $remainder =~ s{ []] \s* $}{}x;
+ $keep = 1;
+
+ } elsif ($type eq 'TEXTREL' || $type eq 'DEBUG') {
+ $keep = 1;
+
+ } elsif ($type eq 'FLAGS_1') {
+ # Will contain "NOW" if the binary was built with -Wl,-z,now
+ $remainder =~ s/^Flags:\s*//i;
+ $keep = 1;
+
+ } elsif (($type eq 'FLAGS' && $remainder =~ m/\bBIND_NOW\b/)
+ || $type eq 'BIND_NOW') {
+
+ # Variants of bindnow
+ $type = 'FLAGS_1';
+ $remainder = 'NOW';
+ $keep = 1;
+ }
+
+ $keep = 1
+ if $remainder
+ =~ s{^ (?: Shared \s library | Library \s soname ) : \s [[] (.*) []] }{$1}x;
+
+ next
+ unless $keep;
+
+ # Here we just need RPATH and NEEDS, so ignore the rest for now
+ if ($type eq 'RPATH' || $type eq 'RUNPATH') {
+
+ # RPATH is like PATH
+ my @components = split(/:/, $remainder);
+ $by_object->{$type}{$_} = 1 for @components;
+
+ } elsif ($type eq 'NEEDED' || $type eq 'SONAME') {
+ push(@{ $by_object->{$type} }, $remainder);
+
+ } elsif ($type eq 'TEXTREL' || $type eq 'DEBUG') {
+ $by_object->{$type} = 1;
+
+ } elsif ($type eq 'FLAGS_1') {
+
+ my @flags = split(/\s+/, $remainder);
+ $by_object->{$type}{$_} = 1 for @flags;
+ }
+ }
+ }
+
+ return;
+}
+
+=item section_headers
+
+=cut
+
+sub section_headers {
+ my ($text, $by_object) = @_;
+
+ const my $TOTAL_FIELDS => 11;
+
+ my @lines = split(m{\n}, $text);
+
+ die 'No column labels.'
+ unless @lines;
+
+ my $first = shift @lines;
+
+ my %labels_by_column;
+
+ my $column = 1;
+ for my $label (split($SPACE, $first)) {
+
+ $label =~ s{^ [[] }{}x;
+ $label =~ s{ []] $}{}x;
+
+ $labels_by_column{$column} = $label;
+
+ } continue {
+ ++$column;
+ }
+
+ die 'Not enough column labels.'
+ if keys %labels_by_column != $TOTAL_FIELDS;
+
+ my $row = 1;
+ while (defined(my $line = shift @lines)) {
+
+ next
+ if divert_error('section headers', $line, $by_object);
+
+ last
+ if $line =~ /^Key to Flags:/;
+
+ my %section_header;
+
+ my @matches = (
+ $line =~ m{^ \s*
+ [[] \s* (\S+) []] \s # Nr
+ (\S+)? \s+ # Name
+ (\S+) \s+ # Type
+ ([0-9a-f]+) \s # Address/Addr
+ ([0-9a-f]+) \s # Off
+ ([0-9a-f]+) \s # Size
+ (\S+) \s+ # ES
+ (\S+)? \s+ # Flg
+ (\S+) \s+ # Lk
+ (\S+) \s+ # Inf
+ (\S+) # Al
+ $}x
+ );
+
+ if (@matches != $TOTAL_FIELDS) {
+
+ warn "Parse error in readelf section headers [row $row]: $line";
+ next;
+ }
+
+ for my $column (keys %labels_by_column) {
+
+ my $label = $labels_by_column{$column};
+ my $value = $matches[$column -1] // $EMPTY;
+
+ $section_header{$label} = $value;
+ }
+
+ # http://sco.com/developers/gabi/latest/ch4.sheader.html
+ my $section = Lintian::Elf::Section->new;
+ $section->number($section_header{Nr});
+ $section->name($section_header{Name});
+ $section->type($section_header{Type});
+
+ # readelf uses both
+ $section->address(
+ hex($section_header{Address} // $section_header{Addr}));
+ $section->offset(hex($section_header{Off}));
+ $section->size(hex($section_header{Size}));
+ $section->entry_size(hex($section_header{ES}));
+ $section->flags($section_header{Flg});
+ $section->index_link(hex($section_header{Lk}));
+ $section->index_info(hex($section_header{Inf}));
+ $section->alignment(hex($section_header{Al}));
+
+ die 'No section number.'
+ unless length $section->number;
+
+ $by_object->{'SECTION-HEADERS'}{$section->number} = $section;
+
+ } continue {
+ ++$row;
+ }
+
+ return;
+}
+
+=item symbol_table
+
+=cut
+
+sub symbol_table {
+ my ($text, $by_object) = @_;
+
+ # We (sometimes) need to read the "Version symbols section" first to
+ # use this data and readelf tends to print after this section, so
+ # save for later.
+
+ my @lines = split(m{\n}, $text);
+
+ while (defined(my $line = shift @lines)) {
+
+ next
+ if divert_error('symbol table', $line, $by_object);
+
+ if ($line
+ =~ m{^ \s* (\d+) : \s* [0-9a-f]+ \s+ \d+ \s+ (?:(?:\S+\s+){3}) (?: [[] .* []] \s+)? (\S+) \s+ (.*) \Z}x
+ ) {
+
+ my $symbol_number = $1;
+ my $section_number = $2;
+ my $symbol_name = $3;
+
+ $by_object->{'DYNAMIC-SYMBOLS'}{$symbol_number}{section_number}
+ = $section_number;
+ $by_object->{'DYNAMIC-SYMBOLS'}{$symbol_number}{symbol_name}
+ = $symbol_name;
+ }
+ }
+
+ return;
+}
+
+=item version_symbols
+
+=cut
+
+sub version_symbols {
+ my ($text, $by_object) = @_;
+
+ my @lines = split(m{\n}, $text);
+
+ while (defined(my $line = shift @lines)) {
+
+ next
+ if divert_error('version symbols', $line, $by_object);
+
+ if ($line
+ =~ m{^ \s* [0-9a-f]+ : \s* \S+ \s* (?: [(] \S+ [)] )? (?: \s | \Z ) }xi
+ ){
+
+ while ($line
+ =~ m{ ([0-9a-f]+ h?) \s* (?: [(] (\S+) [)] )? (?: \s | \Z ) }cgix
+ ) {
+
+ my $symbol_number = $1;
+ my $symbol_version = $2;
+
+ # for libfuse2_2.9.9-3_amd64.deb
+ next
+ unless length $symbol_version;
+
+ $symbol_version = "($symbol_version)"
+ if $symbol_number =~ m{ h $}x;
+
+ $by_object->{'SYMBOL-VERSIONS'}{$symbol_number}
+ = $symbol_version;
+ }
+ }
+ }
+
+ return;
+}
+
+=item divert_error
+
+=cut
+
+sub divert_error {
+ my ($section, $line, $by_object) = @_;
+
+ return 0
+ unless $line =~ s{^ readelf: \s+ }{}x;
+
+ if ($line =~ s{^ Error: \s+ }{}x) {
+
+ my $message = "In $section: $line";
+
+ $by_object->{ERRORS} //= [];
+ push(@{$by_object->{ERRORS}}, $message);
+
+ return 1;
+ }
+
+ if ($line =~ s{^ Warning: \s+ }{}x) {
+
+ my $message = "In $section: $line";
+
+ $by_object->{WARNINGS} //= [];
+ push(@{$by_object->{WARNINGS}}, $message);
+
+ return 1;
+ }
+
+ return 0;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Index/FileTypes.pm b/lib/Lintian/Index/FileTypes.pm
new file mode 100644
index 0000000..a71efb3
--- /dev/null
+++ b/lib/Lintian/Index/FileTypes.pm
@@ -0,0 +1,195 @@
+# -*- perl -*- Lintian::Index::FileTypes
+#
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index::FileTypes;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+use Lintian::IPC::Run3 qw(xargs);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $COMMA => q{,};
+const my $NEWLINE => qq{\n};
+
+const my $KEEP_EMPTY_FIELDS => -1;
+const my $GZIP_MAGIC_SIZE => 9;
+const my $GZIP_MAGIC_BYTES => 0x1f8b;
+
+=head1 NAME
+
+Lintian::Index::FileTypes - determine file type via magic.
+
+=head1 SYNOPSIS
+
+ use Lintian::Index;
+
+=head1 DESCRIPTION
+
+Lintian::Index::FileTypes determine file type via magic.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item add_file_types
+
+=cut
+
+sub add_file_types {
+ my ($self) = @_;
+
+ my $savedir = getcwd;
+ chdir $self->basedir
+ or die encode_utf8(
+ $self->identifier . ': Cannot change to directory ' . $self->basedir);
+
+ my $errors = $EMPTY;
+
+ my @files = grep { $_->is_file } @{$self->sorted_list};
+ my @names = map { $_->name } @files;
+
+ my @command = qw(file --raw --no-pad --print0 --print0 --);
+
+ my %file_types;
+
+ xargs(
+ \@command,
+ \@names,
+ sub {
+ my ($stdout, $stderr, $status, @partial) = @_;
+
+ # ignore failures if possible; file returns non-zero and
+ # "ERROR" on parse errors but output is still usable
+
+ # undecoded split allows names with non UTF-8 bytes
+ $stdout =~ s{ \0 $}{}x;
+
+ my @lines = split(m{\0}, $stdout, $KEEP_EMPTY_FIELDS);
+
+ unless (@lines % 2 == 0) {
+ $errors
+ .= 'Did not get an even number lines from file command.'
+ . $NEWLINE;
+ return;
+ }
+
+ while (defined(my $path = shift @lines)) {
+
+ my $type = shift @lines;
+
+ unless (length $path && length $type) {
+ $errors
+ .= "syntax error in file-info output: '$path' '$type'"
+ . $NEWLINE;
+ next;
+ }
+
+ # drop relative prefix, if present
+ $path =~ s{^ [.]/ }{}x;
+
+ $file_types{$path} = $self->adjust_type($path, $type);
+ }
+
+ return;
+ }
+ );
+
+ $_->file_type($file_types{$_->name}) for @files;
+
+ chdir $savedir
+ or die encode_utf8(
+ $self->identifier . ": Cannot change to directory $savedir");
+
+ return $errors;
+}
+
+=item adjust_type
+
+=cut
+
+# some files need to be corrected
+sub adjust_type {
+ my ($self, $name, $file_type) = @_;
+
+ if ($name =~ m{ [.]gz $}ix && $file_type !~ /compressed/) {
+
+ my $item = $self->lookup($name);
+
+ die encode_utf8("Cannot find file $name in index")
+ unless $item;
+
+ my $buffer = $item->magic($GZIP_MAGIC_SIZE);
+ if (length $buffer) {
+
+ # translation of the unpack
+ # nn nn , NN NN NN NN, nn nn, cc - bytes read
+ # $magic, __ __ __ __, __ __, $comp - variables
+ my ($magic, undef, undef, $compression) = unpack('nNnc', $buffer);
+
+ # gzip file magic
+ if ($magic == $GZIP_MAGIC_BYTES) {
+
+ my $augment = 'gzip compressed data';
+
+ # 2 for max compression; RFC1952 suggests this is a
+ # flag and not a value, hence bit operation
+ $augment .= $COMMA . $SPACE . 'max compression'
+ if $compression & 2;
+
+ return $file_type . $COMMA . $SPACE . $augment;
+ }
+ }
+ }
+
+ # some TFMs are categorized as gzip, see Bug#963589
+ return 'data'
+ if $name =~ m{ [.]tfm $}ix
+ && $file_type =~ /gzip compressed data/;
+
+ return $file_type;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Index/Item.pm b/lib/Lintian/Index/Item.pm
new file mode 100644
index 0000000..7ef6c09
--- /dev/null
+++ b/lib/Lintian/Index/Item.pm
@@ -0,0 +1,1567 @@
+# -*- perl -*-
+# Lintian::Index::Item -- Representation of path entry in a package
+#
+# Copyright (C) 2011 Niels Thykier
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index::Item;
+
+use v5.20;
+use warnings;
+use utf8;
+use autodie qw(open);
+
+use Carp qw(croak confess);
+use Const::Fast;
+use Date::Parse qw(str2time);
+use List::SomeUtils qw(all);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Text::Balanced qw(extract_delimited);
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Pointer::Item;
+use Lintian::SlidingWindow;
+use Lintian::Util qw(normalize_link_target);
+
+use Moo;
+use namespace::clean;
+
+use constant {
+ TYPE_FILE => 0x00_01_00_00,
+ TYPE_HARDLINK => 0x00_02_00_00,
+ TYPE_DIR => 0x00_04_00_00,
+ TYPE_SYMLINK => 0x00_08_00_00,
+ TYPE_BLOCK_DEV => 0x00_10_00_00,
+ TYPE_CHAR_DEV => 0x00_20_00_00,
+ TYPE_PIPE => 0x00_40_00_00,
+ TYPE_OTHER => 0x00_80_00_00,
+ TYPE_MASK => 0x00_ff_00_00,
+
+ UNSAFE_PATH => 0x01_00_00_00,
+ FS_PATH_IS_OK => 0x02_00_00_00,
+ OPEN_IS_OK => 0x06_00_00_00, # Implies FS_PATH_IS_OK
+ ACCESS_INFO => 0x07_00_00_00,
+ # 0o6777 == 0xdff, which covers set[ug]id + sticky bit. Accordingly,
+ # 0xffff should be more than sufficient for the foreseeable future.
+ OPERM_MASK => 0x00_00_ff_ff,
+};
+
+use overload (
+ q{""} => \&_as_string,
+ 'qr' => \&_as_regex_ref,
+ 'bool' => \&_bool,
+ q{!} => \&_bool_not,
+ q{.} => \&_str_concat,
+ 'cmp' => \&_str_cmp,
+ 'eq' => \&_str_eq,
+ 'ne' => \&_str_ne,
+ 'fallback' => 0,
+);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $DOT => q{.};
+const my $DOUBLE_DOT => q{..};
+const my $DOUBLE_QUOTE => q{"};
+const my $BACKSLASH => q{\\};
+const my $HASHBANG => q{#!};
+
+const my $MAXIMUM_LINK_DEPTH => 18;
+
+const my $BYTE_MAXIMUM => 255;
+const my $SINGLE_OCTAL_MASK => oct(7);
+const my $DUAL_OCTAL_MASK => oct(77);
+
+const my $ELF_MAGIC_SIZE => 4;
+const my $LINCITY_MAGIC_SIZE => 6;
+const my $SHELL_SCRIPT_MAGIC_SIZE => 2;
+
+const my $READ_BITS => oct(444);
+const my $WRITE_BITS => oct(222);
+const my $EXECUTABLE_BITS => oct(111);
+
+const my $SETUID => oct(4000);
+const my $SETGID => oct(2000);
+
+=head1 NAME
+
+Lintian::Index::Item - Lintian representation of a path entry in a package
+
+=head1 SYNOPSIS
+
+ my ($name, $type, $dir) = ('lintian', 'source', '/path/to/entry');
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item init_from_tar_output
+
+=item get_quoted_filename
+
+=item unescape_c_style
+
+=cut
+
+my $datepattern = qr/\d{4}-\d{2}-\d{2}/;
+my $timepattern = qr/\d{2}\:\d{2}(?:\:\d{2}(?:\.\d+)?)?/;
+my $symlinkpattern = qr/\s+->\s+/;
+my $hardlinkpattern = qr/\s+link\s+to\s+/;
+
+# adapted from https://www.perlmonks.org/?node_id=1056606
+my %T = (
+ (map {chr() => chr} 0..$BYTE_MAXIMUM),
+ (map {sprintf('%o',$_) => chr} 0..($BYTE_MAXIMUM & $SINGLE_OCTAL_MASK)),
+ (map {sprintf('%02o',$_) => chr} 0..($BYTE_MAXIMUM & $DUAL_OCTAL_MASK)),
+ (map {sprintf('%03o',$_) => chr} 0..$BYTE_MAXIMUM),
+ (split //, "r\rn\nb\ba\af\ft\tv\013")
+);
+
+sub unescape_c_style {
+ my ($escaped) = @_;
+
+ (my $result = $escaped) =~ s/\\([0-7]{1,3}|.)/$T{$1}/g;
+
+ return $result;
+}
+
+sub get_quoted_filename {
+ my ($unknown, $skip) = @_;
+
+ # extract quoted file name
+ my ($delimited, $extra)
+ = extract_delimited($unknown, $DOUBLE_QUOTE, $skip, $BACKSLASH);
+
+ return (undef, undef)
+ unless defined $delimited;
+
+ # drop quotes
+ my $cstylename = substr($delimited, 1, (length $delimited) - 2);
+
+ # convert c-style escapes
+ my $name = unescape_c_style($cstylename);
+
+ return ($name, $extra);
+}
+
+sub init_from_tar_output {
+ my ($self, $line) = @_;
+
+ chomp $line;
+
+ # allow spaces in ownership and filenames (#895175 and #950589)
+
+ my ($initial, $size, $date, $time, $remainder)
+ = split(/\s+(\d+)\s+($datepattern)\s+($timepattern)\s+/, $line,2);
+
+ die encode_utf8(
+ $self->index->identifier . ": Cannot parse tar output: $line")
+ unless all { defined } ($initial, $size, $date, $time, $remainder);
+
+ $self->size($size);
+ $self->date($date);
+ $self->time($time);
+
+ my ($permissions, $ownership) = split(/\s+/, $initial, 2);
+ die encode_utf8($self->index->identifier
+ .": Cannot parse permissions and ownership in tar output: $line")
+ unless all { defined } ($permissions, $ownership);
+
+ $self->perm($permissions);
+
+ my ($owner, $group) = split(qr{/}, $ownership, 2);
+ die encode_utf8($self->index->identifier
+ . ": Cannot parse owner and group in tar output: $line")
+ unless all { defined } ($owner, $group);
+
+ $self->owner($owner);
+ $self->group($group);
+
+ my ($name, $extra) = get_quoted_filename($remainder, $EMPTY);
+ die encode_utf8($self->index->identifier
+ . ": Cannot parse file name in tar output: $line")
+ unless all { defined } ($name, $extra);
+
+ # strip relative prefix
+ $name =~ s{^\./+}{}s;
+
+ # slashes cannot appear in names but are sometimes doubled
+ # as in emboss-explorer_2.2.0-10.dsc
+ # better implemented in a Moo trigger on the attribute
+ $name =~ s{/+}{/}g;
+
+ # make sure directories end with a slash, except root
+ $name .= $SLASH
+ if length $name
+ && $self->perm =~ / ^d /msx
+ && $name !~ m{ /$ }msx;
+
+ $self->name($name);
+
+ # look for symbolic link target
+ if ($self->perm =~ /^l/) {
+
+ my ($linktarget, undef) = get_quoted_filename($extra, $symlinkpattern);
+ die encode_utf8($self->index->identifier
+ .": Cannot parse symbolic link target in tar output: $line")
+ unless defined $linktarget;
+
+ # do not remove multiple slashes from symlink targets
+ # caught by symlink-has-double-slash, which is tested
+ # leaves resolution of these links unsolved
+
+ # do not strip relative prefix for symbolic links
+ $self->link($linktarget);
+ }
+
+ # look for hard link target
+ if ($self->perm =~ /^h/) {
+
+ my ($linktarget, undef)= get_quoted_filename($extra, $hardlinkpattern);
+ die encode_utf8($self->index->identifier
+ . ": Cannot parse hard link target in tar output: $line")
+ unless defined $linktarget;
+
+ # strip relative prefix
+ $linktarget =~ s{^\./+}{}s;
+
+ # slashes cannot appear in names but are sometimes doubled
+ # as in emboss-explorer_2.2.0-10.dsc
+ # better implemented in a Moo trigger on the attribute, but requires
+ # separate attributes for hard and symbolic link targets
+ $linktarget =~ s{/+}{/}g;
+
+ $self->link($linktarget);
+ }
+
+ return;
+}
+
+=item bytes_match(REGEX)
+
+Returns the matched string if REGEX matches the file's byte contents,
+or $EMPTY otherwise.
+
+=cut
+
+sub bytes_match {
+ my ($self, $regex) = @_;
+
+ return $EMPTY
+ unless $self->is_file;
+
+ return $EMPTY
+ unless $self->is_open_ok;
+
+ return $EMPTY
+ unless length $regex;
+
+ open(my $fd, '<:raw', $self->unpacked_path);
+ my $sfd = Lintian::SlidingWindow->new;
+ $sfd->handle($fd);
+
+ my $match;
+ while (my $block = $sfd->readwindow) {
+
+ if ($block =~ /($regex)/) {
+
+ $match = $1;
+ last;
+ }
+ }
+
+ close $fd;
+
+ return $match // $EMPTY;
+}
+
+=item mentions_in_operation(REGEX)
+
+Returns the matched string if REGEX matches in a file location
+that is likely an operation (vs text), or $EMPTY otherwise.
+
+=cut
+
+sub mentions_in_operation {
+ my ($self, $regex) = @_;
+
+ # prefer strings(1) output (eg. for ELF) if we have it
+ # may not work as expected on ELF due to ld's SHF_MERGE
+ my $match;
+ if (length $self->strings && $self->strings =~ /($regex)/) {
+ $match = $1;
+
+ } elsif ($self->is_script) {
+ $match = $self->bytes_match($regex);
+ }
+
+ return $match // $EMPTY;
+}
+
+=item magic(COUNT)
+
+Returns the specified COUNT of magic bytes for the file.
+
+=cut
+
+sub magic {
+ my ($self, $count) = @_;
+
+ return $EMPTY
+ if length $self->link;
+
+ return $EMPTY
+ if $self->size < $count;
+
+ return $EMPTY
+ unless $self->is_open_ok;
+
+ my $magic;
+
+ open(my $fd, '<', $self->unpacked_path);
+ die encode_utf8($self->index->identifier
+ . ": Could not read $count bytes from "
+ . $self->name)
+ unless read($fd, $magic, $count) == $count;
+ close $fd;
+
+ return $magic;
+}
+
+=item C<hashbang>
+
+Returns the C<hashbang> for the file if it is a script.
+
+=cut
+
+has hashbang => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $EMPTY
+ unless $self->is_script;
+
+ my $trimmed_bytes = $EMPTY;
+ my $magic;
+
+ open(my $fd, '<', $self->unpacked_path);
+ if (read($fd, $magic, 2) && $magic eq $HASHBANG && !eof($fd)) {
+ $trimmed_bytes = <$fd>;
+ }
+ close $fd;
+
+ # decoding UTF-8 fails on magyarispell_1.6.1-2.dsc and ldc_1.24.0-1.dsc
+
+ # remove comment, if any
+ $trimmed_bytes =~ s/^([^#]*)/$1/;
+
+ # trim both ends
+ $trimmed_bytes =~ s/^\s+|\s+$//g;
+
+ return $trimmed_bytes;
+ }
+);
+
+=item interpreter_with_options
+
+Returns the interpreter requested by a script with options
+after stripping C<env>.
+
+=cut
+
+has interpreter_with_options => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $with_options = $self->hashbang;
+
+ $with_options =~ s{^/usr/bin/env\s+}{};
+
+ return $with_options;
+ }
+);
+
+=item interpreter
+
+Returns the interpreter requested by a script but strips C<env>.
+
+=cut
+
+has interpreter => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $interpreter = $self->interpreter_with_options;
+
+ # keep base command without options
+ $interpreter =~ s/^(\S+).*/$1/;
+
+ return $interpreter;
+ }
+);
+
+=item C<calls_env>
+
+Returns true if file is a script that calls C<env>.
+
+=cut
+
+has calls_env => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # must return a boolean success value #943724
+ return 1
+ if $self->hashbang =~ m{^/usr/bin/env\s+};
+
+ return 0;
+ }
+);
+
+=item C<is_shell_script>
+
+Returns true if file is a script requesting a recognized shell
+interpreter.
+
+=cut
+
+has is_shell_script => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $interpreter = $self->interpreter;
+
+ # keep basename
+ my ($basename) = ($interpreter =~ m{([^/]*)/?$}s);
+
+ return 1
+ if $basename =~ /^(?:[bd]?a|t?c|(?:pd|m)?k|z)?sh$/;
+
+ return 0;
+ }
+);
+
+=item is_elf
+
+Returns true if file is an ELF executable, and false otherwise.
+
+=cut
+
+has is_elf => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 1
+ if $self->magic($ELF_MAGIC_SIZE) eq "\x7FELF";
+
+ return 0;
+ }
+);
+
+=item is_script
+
+Returns true if file is a script and false otherwise.
+
+=cut
+
+has is_script => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # skip lincity data files; magic: #!#!#!
+ return 0
+ if $self->magic($LINCITY_MAGIC_SIZE) eq '#!#!#!';
+
+ return 0
+ unless $self->magic($SHELL_SCRIPT_MAGIC_SIZE) eq $HASHBANG;
+
+ return 1;
+ }
+);
+
+=item is_maintainer_script
+
+Returns true if file is a maintainer script and false otherwise.
+
+=cut
+
+has is_maintainer_script => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return 1
+ if $self->name =~ /^ config | (?:pre|post)(?:inst|rm) $/x
+ && $self->is_open_ok;
+
+ return 0;
+ }
+);
+
+=item identity
+
+Returns the owner and group of the path, separated by a slash.
+
+NB: If only numerical owner information is available in the package,
+this may return a numerical owner (except uid 0 is always mapped to
+"root")
+
+=cut
+
+sub identity {
+ my ($self) = @_;
+
+ return $self->owner . $SLASH . $self->group;
+}
+
+=item operm
+
+Returns the file permissions of this object in octal (e.g. 0644).
+
+NB: This is only well defined for file entries that are subject to
+permissions (e.g. files). Particularly, the value is not well defined
+for symlinks.
+
+=cut
+
+sub operm {
+ my ($self) = @_;
+
+ return $self->path_info & OPERM_MASK;
+}
+
+=item octal_permissions
+
+=cut
+
+sub octal_permissions {
+ my ($self) = @_;
+
+ return sprintf('%04o', $self->operm);
+}
+
+=item children
+
+Returns a list of children (as Lintian::File::Path objects) of this entry.
+The list and its contents should not be modified.
+
+Only returns direct children of this directory. The entries are sorted by name.
+
+NB: Returns the empty list for non-dir entries.
+
+=cut
+
+sub children {
+ my ($self) = @_;
+
+ croak encode_utf8('No index in ' . $self->name)
+ unless defined $self->index;
+
+ my @names = values %{$self->childnames};
+
+ return map { $self->index->lookup($_) } @names;
+}
+
+=item descendants
+
+Returns a list of children (as Lintian::File::Path objects) of this entry.
+The list and its contents should not be modified.
+
+Descends recursively into subdirectories and return the descendants in
+breadth-first order. Children of a given directory will be sorted by
+name.
+
+NB: Returns the empty list for non-dir entries.
+
+=cut
+
+sub descendants {
+ my ($self) = @_;
+
+ my @descendants = $self->children;
+
+ my @directories = grep { $_->is_dir } @descendants;
+ push(@descendants, $_->descendants) for @directories;
+
+ return @descendants;
+}
+
+=item timestamp
+
+Returns a Unix timestamp for the given path. This is a number of
+seconds since the start of Unix epoch in UTC.
+
+=cut
+
+sub timestamp {
+ my ($self) = @_;
+
+ my $timestamp = $self->date . $SPACE . $self->time;
+
+ return str2time($timestamp, 'GMT');
+}
+
+=item child(BASENAME)
+
+Returns the child named BASENAME if it is a child of this directory.
+Otherwise, this method returns C<undef>.
+
+Even for directories, BASENAME should not end with a slash.
+
+When invoked on non-dirs, this method always returns C<undef>.
+
+Example:
+
+ $dir_entry->child('foo') => $entry OR undef
+
+=cut
+
+sub child {
+ my ($self, $basename) = @_;
+
+ croak encode_utf8('No index in ' . $self->name)
+ unless defined $self->index;
+
+ croak encode_utf8($self->index->identifier . ': Basename is required')
+ unless length $basename;
+
+ my $childname = $self->childnames->{$basename};
+ return undef
+ unless $childname;
+
+ return $self->index->lookup($childname);
+}
+
+=item is_symlink
+
+Returns a truth value if this entry is a symlink.
+
+=item is_hardlink
+
+Returns a truth value if this entry is a hardlink to a regular file.
+
+NB: The target of a hardlink is always a regular file (and not a dir etc.).
+
+=item is_dir
+
+Returns a truth value if this entry is a dir.
+
+NB: Unlike the "-d $dir" operator this will never return true for
+symlinks, even if the symlink points to a dir.
+
+=item is_file
+
+Returns a truth value if this entry is a regular file (or a hardlink to one).
+
+NB: Unlike the "-f $file" operator this will never return true for
+symlinks, even if the symlink points to a file (or hardlink).
+
+=item is_regular_file
+
+Returns a truth value if this entry is a regular file.
+
+This is eqv. to $path->is_file and not $path->is_hardlink.
+
+NB: Unlike the "-f $file" operator this will never return true for
+symlinks, even if the symlink points to a file.
+
+=cut
+
+sub is_symlink {
+ my ($self) = @_;
+
+ return $self->path_info & TYPE_SYMLINK ? 1 : 0;
+}
+
+sub is_hardlink {
+ my ($self) = @_;
+
+ return $self->path_info & TYPE_HARDLINK ? 1 : 0;
+}
+
+sub is_dir {
+ my ($self) = @_;
+
+ return $self->path_info & TYPE_DIR ? 1 : 0;
+}
+
+sub is_file {
+ my ($self) = @_;
+
+ return $self->path_info & (TYPE_FILE | TYPE_HARDLINK) ? 1 : 0;
+}
+
+sub is_regular_file {
+ my ($self) = @_;
+
+ return $self->path_info & TYPE_FILE ? 1 : 0;
+}
+
+=item link_normalized
+
+Returns the target of the link normalized against it's directory name.
+If the link cannot be normalized or normalized path might escape the
+package root, this method returns C<undef>.
+
+NB: This method will return the empty string for links pointing to the
+root dir of the package.
+
+Only available on "links" (i.e. symlinks or hardlinks). On non-links
+this will croak.
+
+I<Symlinks only>: If you want the symlink target as a L<Lintian::File::Path>
+object, use the L<resolve_path|/resolve_path([PATH])> method with no
+arguments instead.
+
+=cut
+
+has link_normalized => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $name = $self->name;
+ my $link = $self->link;
+
+ croak encode_utf8($self->index->identifier . ": $name is not a link")
+ unless length $link;
+
+ my $dir = $self->dirname;
+
+ # hardlinks are always relative to the package root
+ $dir = $SLASH
+ if $self->is_hardlink;
+
+ my $target = normalize_link_target($dir, $link);
+
+ return $target;
+ }
+);
+
+=item is_readable
+
+Returns a truth value if the permission bits of this entry have
+at least one bit denoting readability set (bitmask 0444).
+
+=item is_writable
+
+Returns a truth value if the permission bits of this entry have
+at least one bit denoting writability set (bitmask 0222).
+
+=item is_executable
+
+Returns a truth value if the permission bits of this entry have
+at least one bit denoting executability set (bitmask 0111).
+
+=cut
+
+sub is_readable {
+ my ($self) = @_;
+
+ return $self->path_info & $READ_BITS;
+}
+
+sub is_writable {
+ my ($self) = @_;
+
+ return $self->path_info & $WRITE_BITS;
+}
+
+sub is_executable {
+ my ($self) = @_;
+
+ return $self->path_info & $EXECUTABLE_BITS;
+}
+
+=item all_bits_set
+
+=cut
+
+sub all_bits_set {
+ my ($self, $bits) = @_;
+
+ return ($self->operm & $bits) == $bits;
+}
+
+=item is_setuid
+
+=cut
+
+sub is_setuid {
+ my ($self) = @_;
+
+ return $self->operm & $SETUID;
+}
+
+=item is_setgid
+
+=cut
+
+sub is_setgid {
+ my ($self) = @_;
+
+ return $self->operm & $SETGID;
+}
+
+=item unpacked_path
+
+Returns the path to this object on the file system, which must be a
+regular file, a hardlink or a directory.
+
+This method may fail if:
+
+=over 4
+
+=item * The object is neither a directory or a file-like object (e.g. a
+named pipe).
+
+=item * If the object is dangling symlink or the path traverses a symlink
+outside the package root.
+
+=back
+
+To test if this is safe to call, if the target is (supposed) to be a:
+
+=over 4
+
+=item * file or hardlink then test with L</is_open_ok>.
+
+=item * dir then assert L<resolve_path|/resolve_path([PATH])> returns a
+defined entry, for which L</is_dir> returns a truth value.
+
+=back
+
+=cut
+
+sub unpacked_path {
+ my ($self) = @_;
+
+ $self->_check_access;
+
+ croak encode_utf8('No index in ' . $self->name)
+ unless defined $self->index;
+
+ my $basedir = $self->index->basedir;
+
+ croak encode_utf8($self->index->identifier . ': No base directory')
+ unless length $basedir;
+
+ my $unpacked = path($basedir)->child($self->name)->stringify;
+
+ # bug in perl, file operator should not care but does
+ # https://github.com/Perl/perl5/issues/10550
+ # also, https://github.com/Perl/perl5/issues/9674
+ utf8::downgrade $unpacked;
+
+ return $unpacked;
+}
+
+=item is_open_ok
+
+Returns a truth value if it is safe to attempt open a read handle to
+the underlying file object.
+
+Returns a truth value if the path may be opened.
+
+=cut
+
+sub is_open_ok {
+ my ($self) = @_;
+
+ my $path_info = $self->path_info;
+
+ return 1
+ if ($path_info & OPEN_IS_OK) == OPEN_IS_OK;
+
+ return 0
+ if $path_info & ACCESS_INFO;
+
+ try {
+ $self->_check_open;
+
+ } catch {
+ return 0;
+
+ # perlcritic 1.140-1 requires the semicolon on the next line
+ };
+
+ return 1;
+}
+
+sub _check_access {
+ my ($self) = @_;
+
+ my $path_info = $self->path_info;
+
+ return 1
+ if ($path_info & FS_PATH_IS_OK) == FS_PATH_IS_OK;
+
+ return 0
+ if $path_info & ACCESS_INFO;
+
+ my $resolvable = $self->resolve_path;
+ unless ($resolvable) {
+ $self->path_info($self->path_info | UNSAFE_PATH);
+ # NB: We are deliberately vague here to avoid suggesting
+ # whether $path exists. In some cases (e.g. lintian.d.o)
+ # the output is readily available to wider public.
+ confess encode_utf8($self->index->identifier
+ .': Attempt to access through broken or unsafe symlink: '
+ . $self->name);
+ }
+
+ $self->path_info($self->path_info | FS_PATH_IS_OK);
+
+ return 1;
+}
+
+sub _check_open {
+ my ($self) = @_;
+
+ $self->_check_access;
+
+ # Symlinks can point to a "non-file" object inside the
+ # package root
+ # Leave "_path_access" here as _check_access marks it either as
+ # "UNSAFE_PATH" or "FS_PATH_IS_OK"
+
+ confess encode_utf8($self->index->identifier
+ .': Opening of irregular file not supported: '
+ . $self->name)
+ unless $self->is_file || ($self->is_symlink && -e $self->unpacked_path);
+
+ $self->path_info($self->path_info | OPEN_IS_OK);
+
+ return 1;
+}
+
+=item follow
+
+Return dereferenced link if applicable
+
+=cut
+
+sub follow {
+ my ($self, $maxlinks) = @_;
+
+ return $self
+ unless length $self->link;
+
+ return $self->dereferenced
+ if defined $self->dereferenced;
+
+ # set limit
+ $maxlinks //= $MAXIMUM_LINK_DEPTH;
+
+ # catch recursive links
+ return undef
+ if $maxlinks <= 0;
+
+ # reduce counter
+ $maxlinks--;
+
+ my $reference;
+
+ croak encode_utf8('No index in ' . $self->name)
+ unless defined $self->index;
+
+ if ($self->is_hardlink) {
+ # hard links are resolved against package root
+ $reference = $self->index->lookup;
+
+ } else {
+ # otherwise resolve against the parent
+ $reference = $self->parent_dir;
+ }
+
+ croak encode_utf8($self->index->identifier
+ . ': No parent reference for link in '
+ . $self->name)
+ unless defined $reference;
+
+ # follow link
+ my $dereferenced = $reference->resolve_path($self->link, $maxlinks);
+ $self->dereferenced($dereferenced);
+
+ return $self->dereferenced;
+}
+
+=item resolve_path([PATH])
+
+Resolve PATH relative to this path entry.
+
+If PATH starts with a slash and the file hierarchy has a well-defined
+root directory, then PATH will instead be resolved relatively to the
+root dir. If the file hierarchy does not have a well-defined root dir
+(e.g. for source packages), this method will return C<undef>.
+
+If PATH is omitted, then the entry is resolved and the target is
+returned if it is valid. Except for symlinks, all entries always
+resolve to themselves. NB: hardlinks also resolve as themselves.
+
+It is an error to attempt to resolve a PATH against a non-directory
+and non-symlink entry - as such resolution would always fail
+(i.e. foo/../bar is an invalid path unless foo is a directory or a
+symlink to a dir).
+
+
+The resolution takes symlinks into account and following them provided
+that the target path is valid (and can be followed safely). If the
+path is invalid or circular (symlinks), escapes the root directory or
+follows an unsafe symlink, the method returns C<undef>. Otherwise, it
+returns the path entry that denotes the target path.
+
+
+If PATH contains at least one path segment and ends with a slash, then
+the resolved path will end in a directory (or fail). Otherwise, the
+resolved PATH can end in any entry I<except> a symlink.
+
+Examples:
+
+ $symlink_entry->resolve_path => $nonsymlink_entry OR undef
+
+ $x->resolve_path => $x
+
+ For directory or symlink entries (dol), you can also resolve a path:
+
+ $dol_entry->resolve_path('some/../where') => $nonsymlink_entry OR undef
+
+ # Note the trailing slash
+ $dol_entry->resolve_path('some/../where/') => $dir_entry OR undef
+
+=cut
+
+sub resolve_path {
+ my ($self, $request, $maxlinks) = @_;
+
+ croak encode_utf8('No index in ' . $self->name)
+ unless defined $self->index;
+
+ croak encode_utf8(
+ $self->index->identifier . ': Can only resolve string arguments')
+ if defined $request && ref($request) ne $EMPTY;
+
+ $request //= $EMPTY;
+
+ if (length $self->link) {
+ # follow the link
+ my $dereferenced = $self->follow($maxlinks);
+ return undef
+ unless defined $dereferenced;
+
+ # and use that to resolve the request
+ return $dereferenced->resolve_path($request, $maxlinks);
+ }
+
+ my $reference;
+
+ # check for absolute reference; remove slash
+ if ($request =~ s{^/+}{}s) {
+
+ # require anchoring for absolute references
+ return undef
+ unless $self->index->anchored;
+
+ # get root entry
+ $reference = $self->index->lookup;
+
+ } elsif ($self->is_dir) {
+ # directories are their own starting point
+ $reference = $self;
+
+ } else {
+ # otherwise, use parent directory
+ $reference = $self->parent_dir;
+ }
+
+ return undef
+ unless defined $reference;
+
+ # read first segment; strip all trailing slashes for recursive use
+ if ($request =~ s{^([^/]+)/*}{}) {
+
+ my $segment = $1;
+
+ # single dot, or two slashes in a row
+ return $reference->resolve_path($request, $maxlinks)
+ if $segment eq $DOT || !length $segment;
+
+ # for double dot, go up a level
+ if ($segment eq $DOUBLE_DOT) {
+ my $parent = $reference->parent_dir;
+ return undef
+ unless defined $parent;
+
+ return $parent->resolve_path($request, $maxlinks);
+ }
+
+ # look for child otherwise
+ my $child = $reference->child($segment);
+ return undef
+ unless defined $child;
+
+ return $child->resolve_path($request, $maxlinks);
+ }
+
+ croak encode_utf8($self->index->identifier
+ . ": Cannot parse path resolution request: $request")
+ if length $request;
+
+ # nothing else to resolve
+ return $self;
+}
+
+=item name
+
+Returns the name of the file (relative to the package root).
+
+NB: It will never have any leading "./" (or "/") in it.
+
+=item basename
+
+Returns the "filename" part of the name, similar basename(1) or
+File::Basename::basename (without passing a suffix to strip in either
+case).
+
+NB: Returns the empty string for the "root" dir.
+
+=item dirname
+
+Returns the "directory" part of the name, similar to dirname(1) or
+File::Basename::dirname. The dirname will end with a trailing slash
+(except the "root" dir - see below).
+
+NB: Returns the empty string for the "root" dir.
+
+=item link
+
+If this is a link (i.e. is_symlink or is_hardlink returns a truth
+value), this method returns the target of the link.
+
+If this is not a link, then this returns undef.
+
+If the path is a symlink this method can be used to determine if the
+symlink is relative or absolute. This is I<not> true for hardlinks,
+where the link target is always relative to the root.
+
+NB: Even for symlinks, a leading "./" will be stripped.
+
+=item normalized
+
+=item faux
+
+Returns a truth value if this entry absent in the package. This can
+happen if a package does not include all intermediate directories.
+
+=item size
+
+Returns the size of the path in bytes.
+
+NB: Only regular files can have a non-zero file size.
+
+=item date
+
+Return the modification date as YYYY-MM-DD.
+
+=item time
+
+=item perm
+
+=item path_info
+
+=item owner
+
+Returns the owner of the path entry as a username.
+
+NB: If only numerical owner information is available in the package,
+this may return a numerical owner (except uid 0 is always mapped to
+"root")
+
+=item group
+
+Returns the group of the path entry as a username.
+
+NB: If only numerical owner information is available in the package,
+this may return a numerical group (except gid 0 is always mapped to
+"root")
+
+=item uid
+
+Returns the uid of the owner of the path entry.
+
+NB: If the uid is not available, 0 will be returned.
+This usually happens if the numerical data is not collected (e.g. in
+source packages)
+
+=item gid
+
+Returns the gid of the owner of the path entry.
+
+NB: If the gid is not available, 0 will be returned.
+This usually happens if the numerical data is not collected (e.g. in
+source packages)
+
+=item file_type
+
+Return the data from L<file(1)> if it has been collected.
+
+Note this is only defined for files as Lintian only runs L<file(1)> on
+files.
+
+=item java_info
+
+=item strings
+
+=item C<basedir>
+
+=item index
+
+=item parent_dir
+
+=item child_table
+
+=item sorted_children
+
+Returns the parent directory entry of this entry as a
+L<Lintian::File::Path>.
+
+NB: Returns C<undef> for the "root" dir.
+
+=item C<childnames>
+
+=item parent_dir
+
+Return the parent dir entry of this the path entry.
+
+=item dereferenced
+
+=cut
+
+has name => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($string) = @_; return $string // $EMPTY;},
+ trigger => sub {
+ my ($self, $name) = @_;
+
+ my ($basename) = ($name =~ m{([^/]*)/?$}s);
+ $self->basename($basename);
+
+ # allow newline in names; need /s for dot matching (#929729)
+ my ($dirname) = ($name =~ m{^(.+/)?(?:[^/]+/?)$}s);
+ $self->dirname($dirname);
+ },
+ default => $EMPTY
+);
+has basename => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($string) = @_; return $string // $EMPTY;},
+ default => $EMPTY
+);
+has dirname => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($string) = @_; return $string // $EMPTY;},
+ default => $EMPTY
+);
+
+has link => (
+ is => 'rw',
+ coerce => sub { my ($string) = @_; return $string // $EMPTY;},
+ default => $EMPTY
+);
+has normalized => (
+ is => 'rw',
+ coerce => sub { my ($string) = @_; return $string // $EMPTY;},
+ default => $EMPTY
+);
+has faux => (is => 'rw', default => 0);
+
+has size => (is => 'rw', default => 0);
+has date => (
+ is => 'rw',
+ default => sub {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime;
+ return sprintf('%04d-%02d-%02d', $year, $mon, $mday);
+ }
+);
+has time => (
+ is => 'rw',
+ default => sub {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime;
+ return sprintf('%02d:%02d:%02d', $hour, $min, $sec);
+ }
+);
+
+has perm => (is => 'rw');
+has path_info => (is => 'rw');
+
+has owner => (
+ is => 'rw',
+ coerce => sub { my ($string) = @_; return $string // 'root'; },
+ default => 'root'
+);
+has group => (
+ is => 'rw',
+ coerce => sub { my ($string) = @_; return $string // 'root'; },
+ default => 'root'
+);
+has uid => (
+ is => 'rw',
+ coerce => sub { my ($value) = @_; return int($value // 0); },
+ default => 0
+);
+has gid => (
+ is => 'rw',
+ coerce => sub { my ($value) = @_; return int($value // 0); },
+ default => 0
+);
+
+has md5sum => (
+ is => 'rw',
+ coerce => sub { my ($checksum) = @_; return ($checksum // 0); },
+ default => 0
+);
+has file_type => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+has java_info => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+has strings => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+has ar_info => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has index => (is => 'rw');
+has childnames => (is => 'rw', default => sub { {} });
+has parent_dir => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # do not return root as its own parent
+ return
+ if $self->name eq $EMPTY;
+
+ croak encode_utf8('No index in ' . $self->name)
+ unless defined $self->index;
+
+ # returns root by default
+ return $self->index->lookup($self->dirname);
+ }
+);
+has dereferenced => (is => 'rw');
+
+=item elf
+
+=cut
+
+sub elf {
+ my ($self, @args) = @_;
+
+ if (@args) {
+
+ $self->index->elf_storage->{$self->name} = $args[0];
+
+ return ();
+ }
+
+ my %copy = %{$self->index->elf_storage->{$self->name} // {} };
+
+ return \%copy;
+}
+
+=item elf_by_member
+
+=cut
+
+sub elf_by_member {
+ my ($self, @args) = @_;
+
+ if (@args) {
+
+ my $object_name = $args[0];
+ my $by_object = $args[1];
+
+ my $tmp = $self->index->elf_storage_by_member->{$self->name} // {};
+ $tmp->{$object_name} = $by_object;
+ $self->index->elf_storage_by_member->{$self->name} = $tmp;
+
+ return ();
+ }
+
+ my %copy = %{$self->index->elf_storage_by_member->{$self->name} // {} };
+
+ return \%copy;
+}
+
+=item pointer
+
+=cut
+
+sub pointer {
+ my ($self, $position) = @_;
+
+ my $pointer = Lintian::Pointer::Item->new;
+ $pointer->item($self);
+ $pointer->position($position);
+
+ return $pointer;
+}
+
+=item bytes
+
+Returns verbatim file contents as a scalar.
+
+=item is_valid_utf8
+
+Boolean true if file contents are valid UTF-8.
+
+=item decoded_utf8
+
+Returns a decoded, wide-character string if file contents are valid UTF-8.
+
+=cut
+
+sub bytes {
+ my ($self) = @_;
+
+ return $EMPTY
+ unless $self->is_open_ok;
+
+ my $bytes = path($self->unpacked_path)->slurp;
+
+ return $bytes;
+}
+
+sub is_valid_utf8 {
+ my ($self) = @_;
+
+ my $bytes = $self->bytes;
+ return 0
+ unless defined $bytes;
+
+ return valid_utf8($bytes);
+}
+
+sub decoded_utf8 {
+ my ($self) = @_;
+
+ return $EMPTY
+ unless $self->is_valid_utf8;
+
+ return decode_utf8($self->bytes);
+}
+
+### OVERLOADED OPERATORS ###
+
+# overload apparently does not like the mk_ro_accessor, so use a level
+# of indirection
+
+sub _as_regex_ref {
+ my ($self) = @_;
+ my $name = $self->name;
+ return qr{ \Q$name\E }xsm;
+}
+
+sub _as_string {
+ my ($self) = @_;
+ return $self->name;
+}
+
+sub _bool {
+ # Always true (used in "if ($info->index('some/path')) {...}")
+ return 1;
+}
+
+sub _bool_not {
+ my ($self) = @_;
+ return !$self->_bool;
+}
+
+sub _str_cmp {
+ my ($self, $str, $swap) = @_;
+ return $str cmp $self->name if $swap;
+ return $self->name cmp $str;
+}
+
+sub _str_concat {
+ my ($self, $str, $swap) = @_;
+ return $str . $self->name if $swap;
+ return $self->name . $str;
+}
+
+sub _str_eq {
+ my ($self, $str) = @_;
+ return $self->name eq $str;
+}
+
+sub _str_ne {
+ my ($self, $str) = @_;
+ return $self->name ne $str;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
+
diff --git a/lib/Lintian/Index/Java.pm b/lib/Lintian/Index/Java.pm
new file mode 100644
index 0000000..4b33bec
--- /dev/null
+++ b/lib/Lintian/Index/Java.pm
@@ -0,0 +1,258 @@
+# -*- perl -*- Lintian::Index::Java
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index::Java;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
+use Const::Fast;
+use Cwd;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $NEWLINE => qq{\n};
+const my $SPACE => q{ };
+const my $DASH => q{-};
+
+const my $JAVA_MAGIC_SIZE => 8;
+const my $JAVA_MAGIC_BYTES => 0xCAFEBABE;
+
+=head1 NAME
+
+Lintian::Index::Java - java information.
+
+=head1 SYNOPSIS
+
+ use Lintian::Index;
+
+=head1 DESCRIPTION
+
+Lintian::Index::Java java information.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item add_java
+
+=cut
+
+sub add_java {
+ my ($self) = @_;
+
+ my $savedir = getcwd;
+ chdir($self->basedir)
+ or die encode_utf8(
+ $self->identifier . ': Cannot change to directory ' . $self->basedir);
+
+ my $errors = $EMPTY;
+
+ my @files = grep { $_->is_file } @{$self->sorted_list};
+
+ # Wheezy's version of file calls "jar files" for "Zip archive".
+ # Newer versions seem to call them "Java Jar file".
+ # Jessie also introduced "Java archive data (JAR)"...
+ my @java_files = grep {
+ $_->file_type=~ m{
+ Java [ ] (?:Jar [ ] file|archive [ ] data)
+ | Zip [ ] archive
+ | JAR }x;
+ } @files;
+
+ my @lines;
+ for my $file (@java_files) {
+
+ push(@lines, parse_jar($file->name))
+ if $file->name =~ /\S+\.jar$/i;
+ }
+
+ my $file;
+ my $file_list;
+ my $manifest = 0;
+ local $_ = undef;
+
+ my %java_info;
+
+ for my $line (@lines) {
+ chomp $line;
+ next if $line =~ /^\s*$/;
+
+ if ($line =~ /^-- ERROR:\s*(\S.+)$/) {
+ $java_info{$file}{error} = $1;
+
+ } elsif ($line =~ m{^-- MANIFEST: (?:\./)?(?:.+)$}) {
+ # TODO: check $file == $1 ?
+ $java_info{$file}{manifest} = {};
+ $manifest = $java_info{$file}{manifest};
+ $file_list = 0;
+
+ } elsif ($line =~ m{^-- (?:\./)?(.+)$}) {
+ $file = $1;
+ $java_info{$file}{files} = {};
+ $file_list = $java_info{$file}{files};
+ $manifest = 0;
+ } else {
+ if ($manifest && $line =~ m{^ (\S+):\s(.*)$}) {
+ $manifest->{$1} = $2;
+ } elsif ($file_list) {
+ my ($fname, $clmajor) = ($line =~ m{^([^-].*):\s*([-\d]+)$});
+ $file_list->{$fname} = $clmajor;
+ }
+ }
+ }
+
+ $_->java_info($java_info{$_->name}) for @java_files;
+
+ chdir($savedir)
+ or die encode_utf8(
+ $self->identifier . ": Cannot change to directory $savedir");
+
+ return $errors;
+}
+
+=item parse_jar
+
+=cut
+
+sub parse_jar {
+ my ($path) = @_;
+
+ my @lines;
+
+ # This script needs unzip, there's no way around.
+ push(@lines, "-- $path");
+
+ # Without this Archive::Zip will emit errors to standard error for
+ # faulty zip files - but that is not what we want. AFAICT, it is
+ # the only way to get a textual error as well, so (ab)use it for
+ # this purpose while we are at it.
+ my $errorhandler = sub {
+ my ($err) = @_;
+ $err =~ s/\r?\n/ /g;
+
+ # trim right
+ $err =~ s/\s+$//;
+
+ push(@lines, "-- ERROR: $err");
+ };
+ my $oldhandler = Archive::Zip::setErrorHandler($errorhandler);
+
+ my $azip = Archive::Zip->new;
+ if($azip->read($path) == AZ_OK) {
+
+ # save manifest for the end
+ my $manifest;
+
+ # file list comes first
+ foreach my $member ($azip->members) {
+ my $name = $member->fileName;
+
+ next
+ if $member->isDirectory;
+
+ # store for later processing
+ $manifest = $member
+ if $name =~ m{^META-INF/MANIFEST.MF$}i;
+
+ # add version if we can find it
+ my $jversion;
+ if ($name =~ /\.class$/) {
+ # Collect the Major version of the class file.
+ my ($contents, $zerr) = $member->contents;
+
+ # bug in Archive::Zip; seen in android-platform-libcore_10.0.0+r36-1.dsc
+ last
+ unless defined $zerr;
+
+ last
+ unless $zerr == AZ_OK;
+
+ # Ensure we can read at least 8 bytes for the unpack.
+ next
+ if length $contents < $JAVA_MAGIC_SIZE;
+
+ # translation of the unpack
+ # NN NN NN NN, nn nn, nn nn - bytes read
+ # $magic , __ __, $major - variables
+ my ($magic, undef, $major) = unpack('Nnn', $contents);
+ $jversion = $major
+ if $magic == $JAVA_MAGIC_BYTES;
+ }
+ push(@lines, "$name: " . ($jversion // $DASH));
+ }
+
+ if ($manifest) {
+ push(@lines, "-- MANIFEST: $path");
+
+ my ($contents, $zerr) = $manifest->contents;
+
+ # bug in Archive::Zip; seen in android-platform-libcore_10.0.0+r36-1.dsc
+ return ()
+ unless defined $zerr;
+
+ if ($zerr == AZ_OK) {
+ my $partial = $EMPTY;
+ my $first = 1;
+ my @list = split($NEWLINE, $contents);
+ foreach my $line (@list) {
+
+ # remove DOS type line feeds
+ $line =~ s/\r//g;
+
+ if ($line =~ /^(\S+:)\s*(.*)/) {
+ push(@lines, $SPACE . $SPACE . "$1 $2");
+ }
+ if ($line =~ /^ (.*)/) {
+ push(@lines, $1);
+ }
+ }
+ }
+ }
+ }
+
+ Archive::Zip::setErrorHandler($oldhandler);
+
+ return @lines;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Index/Md5sums.pm b/lib/Lintian/Index/Md5sums.pm
new file mode 100644
index 0000000..c1d0583
--- /dev/null
+++ b/lib/Lintian/Index/Md5sums.pm
@@ -0,0 +1,127 @@
+# -*- perl -*- Lintian::Index::Md5sums
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index::Md5sums;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+use Lintian::IPC::Run3 qw(xargs);
+use Lintian::Util qw(read_md5sums);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $NEWLINE => qq{\n};
+
+const my $WAIT_STATUS_SHIFT => 8;
+const my $NULL => qq{\0};
+
+=head1 NAME
+
+Lintian::Index::Md5sums - calculate checksums for index.
+
+=head1 SYNOPSIS
+
+ use Lintian::Index;
+
+=head1 DESCRIPTION
+
+Lintian::Index::Md5sums calculates checksums for an index.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item add_md5sums
+
+=cut
+
+sub add_md5sums {
+ my ($self) = @_;
+
+ my $savedir = getcwd;
+ chdir($self->basedir)
+ or die encode_utf8(
+ $self->identifier . ': Cannot change to directory ' . $self->basedir);
+
+ my $errors = $EMPTY;
+
+ # get the regular files in the index
+ my @files = grep { $_->is_file } @{$self->sorted_list};
+ my @names = map { $_->name } @files;
+
+ my @command = qw(md5sum --);
+
+ my %md5sums;
+
+ xargs(
+ \@command,
+ \@names,
+ sub {
+ my ($stdout, $stderr, $status, @partial) = @_;
+
+ $stderr = decode_utf8($stderr)
+ if length $stderr;
+
+ if ($status) {
+ $errors .= "Cannot run @command: $stderr" . $NEWLINE;
+ return;
+ }
+
+ # undecoded split allows names with non UTF-8 bytes
+ my ($partial_sums, undef) = read_md5sums($stdout);
+
+ $md5sums{$_} = $partial_sums->{$_}for @partial;
+ }
+ );
+
+ $_->md5sum($md5sums{$_->name}) for @files;
+
+ chdir($savedir)
+ or die encode_utf8(
+ $self->identifier . ": Cannot change to directory $savedir");
+
+ return $errors;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Index/Strings.pm b/lib/Lintian/Index/Strings.pm
new file mode 100644
index 0000000..f0e4fa1
--- /dev/null
+++ b/lib/Lintian/Index/Strings.pm
@@ -0,0 +1,99 @@
+# -*- perl -*- Lintian::Index::Strings
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Index::Strings;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+
+=head1 NAME
+
+Lintian::Index::Strings - strings in binary files.
+
+=head1 SYNOPSIS
+
+ use Lintian::Index;
+
+=head1 DESCRIPTION
+
+Lintian::Index::Strings strings in binary files.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item add_strings
+
+=cut
+
+sub add_strings {
+ my ($self) = @_;
+
+ my $errors = $EMPTY;
+
+ my @files = grep { $_->is_file } @{$self->sorted_list};
+ for my $file (@files) {
+
+ next
+ if $file->name =~ m{^usr/lib/debug/};
+
+ # skip non-binaries
+ next
+ unless $file->file_type =~ /\bELF\b/;
+
+ # prior implementations sometimes made the list unique
+ my $allstrings
+ = decode_utf8(safe_qx(qw{strings --all --}, $file->unpacked_path));
+
+ $file->strings($allstrings);
+ }
+
+ return $errors;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Mask.pm b/lib/Lintian/Mask.pm
new file mode 100644
index 0000000..475e65c
--- /dev/null
+++ b/lib/Lintian/Mask.pm
@@ -0,0 +1,76 @@
+# -*- perl -*- Lintian::Mask
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Mask;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Mask - access to mask data
+
+=head1 SYNOPSIS
+
+ use Lintian::Mask;
+
+=head1 DESCRIPTION
+
+Lintian::Mask provides access to mask data.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item screen
+
+=item excuse
+
+=cut
+
+has screen => (is => 'rw', default => $EMPTY);
+
+has excuse => (is => 'rw', default => $EMPTY);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Output/EWI.pm b/lib/Lintian/Output/EWI.pm
new file mode 100644
index 0000000..af0fac6
--- /dev/null
+++ b/lib/Lintian/Output/EWI.pm
@@ -0,0 +1,614 @@
+# Copyright (C) 2008 Frank Lichtenheld <frank@lichtenheld.de>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output::EWI;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use HTML::HTML5::Entities;
+use List::Compare;
+use Term::ANSIColor ();
+use Text::Wrap;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Output::Markdown qw(markdown_citation);
+
+# for tty hyperlinks
+const my $OSC_HYPERLINK => qq{\033]8;;};
+const my $OSC_DONE => qq{\033\\};
+const my $BEL => qq{\a};
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $COLON => q{:};
+const my $DOT => q{.};
+const my $NEWLINE => qq{\n};
+const my $PARAGRAPH_BREAK => $NEWLINE x 2;
+
+const my $YES => q{yes};
+const my $NO => q{no};
+
+const my $COMMENT_PREFIX => q{N:} . $SPACE;
+
+const my $DESCRIPTION_INDENTATION => 2;
+const my $DESCRIPTION_PREFIX => $COMMENT_PREFIX
+ . $SPACE x $DESCRIPTION_INDENTATION;
+
+const my $SCREEN_INDENTATION => 4;
+const my $SCREEN_PREFIX => $COMMENT_PREFIX . $SPACE x $SCREEN_INDENTATION;
+
+const my %COLORS => (
+ 'E' => 'bright_white on_bright_red',
+ 'W' => 'black on_bright_yellow',
+ 'I' => 'bright_white on_bright_blue',
+ 'P' => 'bright_white on_green',
+ 'C' => 'bright_white on_bright_magenta',
+ 'X' => 'bright_white on_yellow',
+ 'O' => 'bright_white on_bright_black',
+ 'M' => 'bright_black on_bright_white',
+);
+
+const my %CODE_PRIORITY => (
+ 'E' => 30,
+ 'W' => 40,
+ 'I' => 50,
+ 'P' => 60,
+ 'X' => 70,
+ 'C' => 80,
+ 'O' => 90,
+ 'M' => 100,
+);
+
+const my %TYPE_PRIORITY => (
+ 'source' => 30,
+ 'binary' => 40,
+ 'udeb' => 50,
+ 'changes' => 60,
+ 'buildinfo' => 70,
+);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Output::Grammar';
+
+=head1 NAME
+
+Lintian::Output::EWI - standard hint output
+
+=head1 SYNOPSIS
+
+ use Lintian::Output::EWI;
+
+=head1 DESCRIPTION
+
+Provides standard hint output.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item tag_count_by_processable
+
+=cut
+
+has tag_count_by_processable => (is => 'rw', default => sub { {} });
+
+=item issue_hints
+
+=cut
+
+sub issue_hints {
+ my ($self, $profile, $groups, $option) = @_;
+
+ my %sorter;
+ for my $group (@{$groups // []}) {
+
+ for my $processable ($group->get_processables) {
+
+ my $type = $processable->type;
+ my $type_priority = $TYPE_PRIORITY{$type};
+
+ for my $hint (@{$processable->hints}) {
+
+ my $tag = $profile->get_tag($hint->tag_name);
+
+ my $override_status = 0;
+ $override_status = 1
+ if defined $hint->override || @{$hint->masks};
+
+ my $ranking_code = $tag->code;
+ $ranking_code = 'X'
+ if $tag->experimental;
+ $ranking_code = 'O'
+ if defined $hint->override;
+ $ranking_code = 'M'
+ if @{$hint->masks};
+
+ my $code_priority = $CODE_PRIORITY{$ranking_code};
+
+ my %for_output;
+ $for_output{hint} = $hint;
+ $for_output{processable} = $processable;
+
+ push(
+ @{
+ $sorter{$override_status}{$code_priority}{$tag->name}
+ {$type_priority}{$processable->name}{$hint->context}
+ },
+ \%for_output
+ );
+ }
+ }
+ }
+
+ for my $override_status (sort keys %sorter) {
+
+ my %by_code_priority = %{$sorter{$override_status}};
+
+ for my $code_priority (sort { $a <=> $b } keys %by_code_priority) {
+
+ my %by_tag_name = %{$by_code_priority{$code_priority}};
+
+ for my $tag_name (sort keys %by_tag_name) {
+
+ my %by_type_priority = %{$by_tag_name{$tag_name}};
+
+ for
+ my $type_priority (sort { $a <=> $b }keys %by_type_priority){
+
+ my %by_processable_name
+ = %{$by_type_priority{$type_priority}};
+
+ for my $processable_name (sort keys %by_processable_name) {
+
+ my %by_context
+ = %{$by_processable_name{$processable_name}};
+
+ for my $context (sort keys %by_context) {
+
+ my $for_output
+ = $sorter{$override_status}{$code_priority}
+ {$tag_name}{$type_priority}{$processable_name}
+ {$context};
+
+ for my $each (@{$for_output}) {
+
+ my $hint = $each->{hint};
+ my $processable = $each->{processable};
+
+ $self->print_hint($profile, $hint,
+ $processable,$option)
+ if ( !defined $hint->override
+ && !@{$hint->masks})
+ || $option->{'show-overrides'};
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+
+ return;
+}
+
+=item C<print_hint>
+
+=cut
+
+sub print_hint {
+ my ($self, $profile, $hint, $processable, $option) = @_;
+
+ my $tag_name = $hint->tag_name;
+ my $tag = $profile->get_tag($tag_name);
+
+ my @want_references = @{$option->{'display-source'} // []};
+ my @have_references = @{$tag->see_also};
+
+ # keep only the first word
+ s{^ ([\w-]+) \s }{$1}x for @have_references;
+
+ # drop anything in parentheses at the end
+ s{ [(] \S+ [)] $}{}x for @have_references;
+
+ # check if hint refers to the selected references
+ my $reference_lc= List::Compare->new(\@have_references, \@want_references);
+
+ my @found_references = $reference_lc->get_intersection;
+
+ return
+ if @want_references
+ && !@found_references;
+
+ my $information = $hint->context;
+ $information = $SPACE . $self->_quote_print($information)
+ unless $information eq $EMPTY;
+
+ # Limit the output so people do not drown in hints. Some hints are
+ # insanely noisy (hi static-library-has-unneeded-section)
+ my $limit = $option->{'tag-display-limit'};
+ if ($limit) {
+
+ my $processable_id = $processable->identifier;
+ my $emitted_count
+ = $self->tag_count_by_processable->{$processable_id}{$tag_name}++;
+
+ return
+ if $emitted_count >= $limit;
+
+ my $msg
+ = ' ... use "--tag-display-limit 0" to see all (or pipe to a file/program)';
+ $information = $self->_quote_print($msg)
+ if $emitted_count >= $limit-1;
+ }
+
+ say encode_utf8('N:')
+ if $option->{info};
+
+ my $text = $tag_name;
+
+ my $code = $tag->code;
+ $code = 'X' if $tag->experimental;
+ $code = 'O' if defined $hint->override;
+ $code = 'M' if @{$hint->masks};
+
+ my $tag_color = $COLORS{$code};
+
+ $text = Term::ANSIColor::colored($tag_name, $tag_color)
+ if $option->{color};
+
+ my $output;
+ if ($option->{hyperlinks} && $option->{color}) {
+ my $target= 'https://lintian.debian.org/tags/' . $tag_name;
+ $output .= $self->osc_hyperlink($text, $target);
+ } else {
+ $output .= $text;
+ }
+
+ local $Text::Wrap::columns
+ = $option->{'output-width'} - length $COMMENT_PREFIX;
+
+ # do not wrap long words such as urls; see #719769
+ local $Text::Wrap::huge = 'overflow';
+
+ if ($hint->override && length $hint->override->justification) {
+
+ my $wrapped = wrap($COMMENT_PREFIX, $COMMENT_PREFIX,
+ $hint->override->justification);
+ say encode_utf8($wrapped);
+ }
+
+ for my $mask (@{$hint->masks}) {
+
+ say encode_utf8($COMMENT_PREFIX . 'masked by screen ' . $mask->screen);
+
+ next
+ unless length $mask->excuse;
+
+ my $wrapped= wrap($COMMENT_PREFIX, $COMMENT_PREFIX, $mask->excuse);
+ say encode_utf8($wrapped);
+ }
+
+ my $type = $EMPTY;
+ $type = $SPACE . $processable->type
+ unless $processable->type eq 'binary';
+
+ say encode_utf8($code
+ . $COLON
+ . $SPACE
+ . $processable->name
+ . $type
+ . $COLON
+ . $SPACE
+ . $output
+ . $information);
+
+ if ($option->{info}) {
+
+ # show only on first issuance
+ $self->describe_tag($profile->data, $tag, $option->{'output-width'})
+ unless $self->issued_tag($tag->name);
+ }
+
+ return;
+}
+
+=item C<_quote_print($string)>
+
+Called to quote a string. By default it will replace all
+non-printables with "?". Sub-classes can override it if
+they allow non-ascii printables etc.
+
+=cut
+
+sub _quote_print {
+ my ($self, $string) = @_;
+
+ $string =~ s/[^[:print:]]/?/g;
+
+ return $string;
+}
+
+=item C<osc_hyperlink>
+
+=cut
+
+sub osc_hyperlink {
+ my ($self, $text, $target) = @_;
+
+ my $start = $OSC_HYPERLINK . $target . $BEL;
+ my $end = $OSC_HYPERLINK . $BEL;
+
+ return $start . $text . $end;
+}
+
+=item issuedtags
+
+Hash containing the names of tags which have been issued.
+
+=cut
+
+has issuedtags => (is => 'rw', default => sub { {} });
+
+=item C<issued_tag($tag_name)>
+
+Indicate that the named tag has been issued. Returns a boolean value
+indicating whether the tag had previously been issued by the object.
+
+=cut
+
+sub issued_tag {
+ my ($self, $tag_name) = @_;
+
+ return $self->issuedtags->{$tag_name}++ ? 1 : 0;
+}
+
+=item describe_tags
+
+=cut
+
+sub describe_tags {
+ my ($self, $data, $tags, $columns) = @_;
+
+ for my $tag (@{$tags}) {
+
+ my $name;
+ my $code;
+
+ if (defined $tag) {
+ $name = $tag->name;
+ $code = $tag->code;
+
+ } else {
+ $name = 'unknown-tag';
+ $code = 'N';
+ }
+
+ say encode_utf8('N:');
+ say encode_utf8("$code: $name");
+
+ $self->describe_tag($data, $tag, $columns);
+ }
+
+ return;
+}
+
+=item describe_tag
+
+=cut
+
+sub describe_tag {
+ my ($self, $data, $tag, $columns) = @_;
+
+ local $Text::Wrap::columns = $columns;
+
+ # do not wrap long words such as urls; see #719769
+ local $Text::Wrap::huge = 'overflow';
+
+ my $wrapped = $COMMENT_PREFIX . $NEWLINE;
+
+ if (defined $tag) {
+
+ my $plain_explanation = markdown_to_plain($tag->explanation,
+ $columns - length $DESCRIPTION_PREFIX);
+
+ $wrapped .= $DESCRIPTION_PREFIX . $_ . $NEWLINE
+ for split(/\n/, $plain_explanation);
+
+ if (@{$tag->see_also}) {
+
+ $wrapped .= $COMMENT_PREFIX . $NEWLINE;
+
+ my @see_also_markdown
+ = map { markdown_citation($data, $_) } @{$tag->see_also};
+ my $markdown
+ = 'Please refer to '
+ . $self->oxford_enumeration('and', @see_also_markdown)
+ . ' for details.'
+ . $NEWLINE;
+ my $plain = markdown_to_plain($markdown,
+ $columns - length $DESCRIPTION_PREFIX);
+
+ $wrapped .= $DESCRIPTION_PREFIX . $_ . $NEWLINE
+ for split(/\n/, $plain);
+ }
+
+ $wrapped .= $COMMENT_PREFIX . $NEWLINE;
+
+ my $visibility_prefix = 'Visibility: ';
+ $wrapped.= wrap(
+ $DESCRIPTION_PREFIX . $visibility_prefix,
+ $DESCRIPTION_PREFIX . $SPACE x length $visibility_prefix,
+ $tag->visibility . $NEWLINE
+ );
+
+ $wrapped .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX,
+ 'Show-Always: '. ($tag->show_always ? $YES : $NO) . $NEWLINE);
+
+ my $check_prefix = 'Check: ';
+ $wrapped .= wrap(
+ $DESCRIPTION_PREFIX . $check_prefix,
+ $DESCRIPTION_PREFIX . $SPACE x length $check_prefix,
+ $tag->check . $NEWLINE
+ );
+
+ if (@{$tag->renamed_from}) {
+
+ $wrapped .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX,
+ 'Renamed from: '
+ . join($SPACE, @{$tag->renamed_from})
+ . $NEWLINE);
+ }
+
+ $wrapped
+ .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX,
+ 'This tag is experimental.' . $NEWLINE)
+ if $tag->experimental;
+
+ $wrapped .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX,
+ 'This tag is a classification. There is no issue in your package.'
+ . $NEWLINE)
+ if $tag->visibility eq 'classification';
+
+ for my $screen (@{$tag->screens}) {
+
+ $wrapped .= $COMMENT_PREFIX . $NEWLINE;
+
+ $wrapped
+ .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX,
+ 'Screen: ' . $screen->name . $NEWLINE);
+
+ $wrapped .= wrap($SCREEN_PREFIX, $SCREEN_PREFIX,
+ 'Advocates: '. join(', ', @{$screen->advocates}). $NEWLINE);
+
+ my $combined = $screen->reason . $NEWLINE;
+ if (@{$screen->see_also}) {
+
+ $combined .= $NEWLINE;
+
+ my @see_also_markdown
+ = map { markdown_citation($data, $_) } @{$screen->see_also};
+ $combined
+ .= 'Read more in '
+ . $self->oxford_enumeration('and', @see_also_markdown)
+ . $DOT
+ . $NEWLINE;
+ }
+
+ my $reason_prefix = 'Reason: ';
+ my $plain = markdown_to_plain($combined,
+ $columns - length($SCREEN_PREFIX . $reason_prefix));
+
+ my @lines = split(/\n/, $plain);
+ $wrapped
+ .= $SCREEN_PREFIX . $reason_prefix . (shift @lines) . $NEWLINE;
+ $wrapped
+ .= $SCREEN_PREFIX
+ . $SPACE x (length $reason_prefix)
+ . $_
+ . $NEWLINE
+ for @lines;
+ }
+
+ } else {
+ $wrapped
+ .= wrap($DESCRIPTION_PREFIX, $DESCRIPTION_PREFIX, 'Unknown tag.');
+ }
+
+ $wrapped .= $COMMENT_PREFIX . $NEWLINE;
+
+ print encode_utf8($wrapped);
+
+ return;
+}
+
+=item markdown_to_plain
+
+=cut
+
+sub markdown_to_plain {
+ my ($markdown, $columns) = @_;
+
+ # use angular brackets for emphasis
+ $markdown =~ s{<i>|<em>}{&lt;}g;
+ $markdown =~ s{</i>|</em>}{&gt;}g;
+
+ # drop Markdown hyperlinks
+ $markdown =~ s{\[([^\]]+)\]\([^\)]+\)}{$1}g;
+
+ # drop all HTML tags except Markdown shorthand <$url>
+ $markdown =~ s{<(?![a-z]+://)[^>]+>}{}g;
+
+ # drop brackets around Markdown shorthand <$url>
+ $markdown =~ s{<([a-z]+://[^>]+)>}{$1}g;
+
+ # substitute HTML entities
+ my $plain = decode_entities($markdown);
+
+ local $Text::Wrap::columns = $columns
+ if defined $columns;
+
+ # do not wrap long words such as urls; see #719769
+ local $Text::Wrap::huge = 'overflow';
+
+ my @paragraphs = split(/\n{2,}/, $plain);
+
+ my @lines;
+ for my $paragraph (@paragraphs) {
+
+ # do not wrap preformatted paragraphs
+ unless ($paragraph =~ /^\s/) {
+
+ # reduce whitespace throughout, including newlines
+ $paragraph =~ s/\s+/ /g;
+
+ # trim beginning and end of each line
+ $paragraph =~ s/^\s+|\s+$//mg;
+
+ $paragraph = wrap($EMPTY, $EMPTY, $paragraph);
+ }
+
+ push(@lines, $EMPTY);
+ push(@lines, split(/\n/, $paragraph));
+ }
+
+ # drop leading blank line
+ shift @lines;
+
+ my $wrapped;
+ $wrapped .= $_ . $NEWLINE for @lines;
+
+ return $wrapped;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Output/Grammar.pm b/lib/Lintian/Output/Grammar.pm
new file mode 100644
index 0000000..e9d62bd
--- /dev/null
+++ b/lib/Lintian/Output/Grammar.pm
@@ -0,0 +1,84 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output::Grammar;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $COMMA => q{,};
+
+=head1 NAME
+
+Lintian::Output::Grammar - sentence helpers
+
+=head1 SYNOPSIS
+
+ use Lintian::Output::Grammar;
+
+=head1 DESCRIPTION
+
+Helps with human readable output.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item oxford_enumeration
+
+=cut
+
+sub oxford_enumeration {
+ my ($self, $conjunctive, @alternatives) = @_;
+
+ return $EMPTY
+ unless @alternatives;
+
+ # remove and save last element
+ my $final = pop @alternatives;
+
+ my $maybe_comma = (@alternatives > 1 ? $COMMA : $EMPTY);
+
+ my $text = $EMPTY;
+ $text = join($COMMA . $SPACE, @alternatives) . "$maybe_comma $conjunctive "
+ if @alternatives;
+
+ $text .= $final;
+
+ return $text;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Output/HTML.pm b/lib/Lintian/Output/HTML.pm
new file mode 100644
index 0000000..8fd1126
--- /dev/null
+++ b/lib/Lintian/Output/HTML.pm
@@ -0,0 +1,331 @@
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output::HTML;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+use Text::Markdown::Discount qw(markdown);
+use Text::Xslate qw(mark_raw);
+use Time::Duration;
+use Time::Moment;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Output::Markdown qw(markdown_citation);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $NEWLINE => qq{\n};
+const my $PARAGRAPH_BREAK => $NEWLINE x 2;
+
+const my %CODE_PRIORITY => (
+ 'E' => 30,
+ 'W' => 40,
+ 'I' => 50,
+ 'P' => 60,
+ 'X' => 70,
+ 'C' => 80,
+ 'O' => 90,
+ 'M' => 100,
+);
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Output::Grammar';
+
+=head1 NAME
+
+Lintian::Output::HTML - standalone HTML hint output
+
+=head1 SYNOPSIS
+
+ use Lintian::Output::HTML;
+
+=head1 DESCRIPTION
+
+Provides standalone HTML hint output.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item issue_hints
+
+Print all hints passed in array. A separate arguments with processables
+is necessary to report in case no hints were found.
+
+=cut
+
+sub issue_hints {
+ my ($self, $profile, $groups) = @_;
+
+ $groups //= [];
+
+ my %output;
+
+ my $lintian_version = $ENV{LINTIAN_VERSION};
+ $output{'lintian-version'} = $lintian_version;
+
+ my @allgroups_output;
+ $output{groups} = \@allgroups_output;
+
+ for my $group (sort { $a->name cmp $b->name } @{$groups}) {
+
+ my %group_output;
+
+ $group_output{'group-id'} = $group->name;
+ $group_output{name} = $group->source_name;
+ $group_output{version} = $group->source_version;
+
+ my $start = Time::Moment->from_string($group->processing_start);
+ my $end = Time::Moment->from_string($group->processing_end);
+ $group_output{start} = $start->strftime('%c');
+ $group_output{end} = $end->strftime('%c');
+ $group_output{duration} = duration($start->delta_seconds($end));
+
+ my @processables = $group->get_processables;
+ my $any_processable = shift @processables;
+ $group_output{'maintainer'}
+ = $any_processable->fields->value('Maintainer');
+
+ push(@allgroups_output, \%group_output);
+
+ my @allfiles_output;
+ $group_output{'input-files'} = \@allfiles_output;
+
+ for my $processable (sort {$a->path cmp $b->path}
+ $group->get_processables) {
+ my %file_output;
+ $file_output{filename} = path($processable->path)->basename;
+ $file_output{hints}
+ = $self->hintlist($profile, $processable->hints);
+ push(@allfiles_output, \%file_output);
+ }
+ }
+
+ my $style_sheet = $profile->data->style_sheet->css;
+
+ my $templatedir = "$ENV{LINTIAN_BASE}/templates";
+ my $tx = Text::Xslate->new(path => [$templatedir]);
+ my $page = $tx->render(
+ 'standalone-html.tx',
+ {
+ title => 'Lintian Tags',
+ style_sheet => mark_raw($style_sheet),
+ output => \%output,
+ }
+ );
+
+ print encode_utf8($page);
+
+ return;
+}
+
+=item C<hintlist>
+
+=cut
+
+sub hintlist {
+ my ($self, $profile, $arrayref) = @_;
+
+ my %sorter;
+ for my $hint (@{$arrayref // []}) {
+
+ my $tag = $profile->get_tag($hint->tag_name);
+
+ my $override_status = 0;
+ $override_status = 1
+ if defined $hint->override || @{$hint->masks};
+
+ my $ranking_code = $tag->code;
+ $ranking_code = 'X'
+ if $tag->experimental;
+ $ranking_code = 'O'
+ if defined $hint->override;
+ $ranking_code = 'M'
+ if @{$hint->masks};
+
+ my $code_priority = $CODE_PRIORITY{$ranking_code};
+
+ push(
+ @{
+ $sorter{$override_status}{$code_priority}{$tag->name}
+ {$hint->context}
+ },
+ $hint
+ );
+ }
+
+ my @sorted;
+ for my $override_status (sort keys %sorter) {
+ my %by_code_priority = %{$sorter{$override_status}};
+
+ for my $code_priority (sort { $a <=> $b } keys %by_code_priority) {
+ my %by_tag_name = %{$by_code_priority{$code_priority}};
+
+ for my $tag_name (sort keys %by_tag_name) {
+ my %by_context = %{$by_tag_name{$tag_name}};
+
+ for my $context (sort keys %by_context) {
+
+ my $hints
+ = $sorter{$override_status}{$code_priority}{$tag_name}
+ {$context};
+
+ push(@sorted, $_)for @{$hints};
+ }
+ }
+ }
+ }
+
+ my @html_hints;
+ for my $hint (@sorted) {
+
+ my $tag = $profile->get_tag($hint->tag_name);
+
+ my %html_hint;
+ push(@html_hints, \%html_hint);
+
+ $html_hint{tag_name} = $hint->tag_name;
+
+ $html_hint{url} = 'https://lintian.debian.org/tags/' . $hint->tag_name;
+
+ $html_hint{context} = $hint->context
+ if length $hint->context;
+
+ $html_hint{visibility} = $tag->visibility;
+
+ $html_hint{visibility} = 'experimental'
+ if $tag->experimental;
+
+ my @comments;
+ if ($hint->override) {
+
+ $html_hint{visibility} = 'override';
+
+ push(@comments, $hint->override->justification)
+ if length $hint->override->justification;
+ }
+
+ # order matters
+ $html_hint{visibility} = 'mask'
+ if @{ $hint->masks };
+
+ for my $mask (@{$hint->masks}) {
+
+ push(@comments, 'masked by screen ' . $mask->screen);
+ push(@comments, $mask->excuse)
+ if length $mask->excuse;
+ }
+
+ $html_hint{comments} = \@comments
+ if @comments;
+ }
+
+ return \@html_hints;
+}
+
+=item describe_tags
+
+=cut
+
+sub describe_tags {
+ my ($self, $data, $tags) = @_;
+
+ for my $tag (@{$tags}) {
+
+ say encode_utf8('<p>Name: ' . $tag->name . '</p>');
+ say encode_utf8($EMPTY);
+
+ print encode_utf8(markdown($self->markdown_description($data, $tag)));
+ }
+
+ return;
+}
+
+=item markdown_description
+
+=cut
+
+sub markdown_description {
+ my ($self, $data, $tag) = @_;
+
+ my $description = $tag->explanation;
+
+ my @extras;
+
+ if (@{$tag->see_also}) {
+
+ my @markdown
+ = map { markdown_citation($data, $_) } @{$tag->see_also};
+ my $references
+ = 'Please refer to '
+ . $self->oxford_enumeration('and', @markdown)
+ . ' for details.';
+
+ push(@extras, $references);
+ }
+
+ push(@extras, 'Visibility: '. $tag->visibility);
+
+ push(@extras, 'Check: ' . $tag->check)
+ if length $tag->check;
+
+ push(@extras, 'Renamed from: ' . join($SPACE, @{$tag->renamed_from}))
+ if @{$tag->renamed_from};
+
+ push(@extras, 'This tag is experimental.')
+ if $tag->experimental;
+
+ push(@extras,
+ 'This tag is a classification. There is no issue in your package.')
+ if $tag->visibility eq 'classification';
+
+ for my $screen (@{$tag->screens}) {
+
+ my $screen_description = 'Screen: ' . $screen->name . $NEWLINE;
+ $screen_description
+ .= 'Advocates: ' . join(', ', @{$screen->advocates}) . $NEWLINE;
+ $screen_description .= 'Reason: ' . $screen->reason . $NEWLINE;
+
+ $screen_description .= 'See-Also: ' . $NEWLINE;
+
+ push(@extras, $screen_description);
+ }
+
+ $description .= $PARAGRAPH_BREAK . $_ for @extras;
+
+ return $description;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Output/JSON.pm b/lib/Lintian/Output/JSON.pm
new file mode 100644
index 0000000..08996e2
--- /dev/null
+++ b/lib/Lintian/Output/JSON.pm
@@ -0,0 +1,322 @@
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output::JSON;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Time::Piece;
+use JSON::MaybeXS;
+
+use Lintian::Output::Markdown qw(markdown_citation);
+
+const my $EMPTY => q{};
+
+const my %CODE_PRIORITY => (
+ 'E' => 30,
+ 'W' => 40,
+ 'I' => 50,
+ 'P' => 60,
+ 'X' => 70,
+ 'C' => 80,
+ 'O' => 90,
+ 'M' => 100,
+);
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Output::JSON - JSON hint output
+
+=head1 SYNOPSIS
+
+ use Lintian::Output::JSON;
+
+=head1 DESCRIPTION
+
+Provides JSON hint output.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item issue_hints
+
+Print all hints passed in array. A separate arguments with processables
+is necessary to report in case no hints were found.
+
+=cut
+
+sub issue_hints {
+ my ($self, $profile, $groups) = @_;
+
+ $groups //= [];
+
+ my %output;
+
+ $output{lintian_version} = $ENV{LINTIAN_VERSION};
+
+ my @allgroups_output;
+ $output{groups} = \@allgroups_output;
+
+ for my $group (sort { $a->name cmp $b->name } @{$groups}) {
+
+ my %group_output;
+ $group_output{group_id} = $group->name;
+ $group_output{source_name} = $group->source_name;
+ $group_output{source_version} = $group->source_version;
+
+ push(@allgroups_output, \%group_output);
+
+ my @allfiles_output;
+ $group_output{input_files} = \@allfiles_output;
+
+ for my $processable (sort {$a->path cmp $b->path}
+ $group->get_processables) {
+
+ my %file_output;
+ $file_output{path} = $processable->path;
+ $file_output{hints}
+ = $self->hintlist($profile, $processable->hints);
+
+ push(@allfiles_output, \%file_output);
+ }
+ }
+
+ # convert to UTF-8 prior to encoding in JSON
+ my $encoder = JSON->new;
+ $encoder->canonical;
+ $encoder->utf8;
+ $encoder->pretty;
+
+ my $json = $encoder->encode(\%output);
+
+ # output encoded JSON; is already in UTF-8
+ print $json;
+
+ return;
+}
+
+=item C<hintlist>
+
+=cut
+
+sub hintlist {
+ my ($self, $profile, $arrayref) = @_;
+
+ my %sorter;
+ for my $hint (@{$arrayref // []}) {
+
+ my $tag = $profile->get_tag($hint->tag_name);
+
+ my $override_status = 0;
+ $override_status = 1
+ if defined $hint->override || @{$hint->masks};
+
+ my $ranking_code = $tag->code;
+ $ranking_code = 'X'
+ if $tag->experimental;
+ $ranking_code = 'O'
+ if defined $hint->override;
+ $ranking_code = 'M'
+ if @{$hint->masks};
+
+ my $code_priority = $CODE_PRIORITY{$ranking_code};
+
+ push(
+ @{
+ $sorter{$override_status}{$code_priority}{$tag->name}
+ {$hint->context}
+ },
+ $hint
+ );
+ }
+
+ my @sorted;
+ for my $override_status (sort keys %sorter) {
+ my %by_code_priority = %{$sorter{$override_status}};
+
+ for my $code_priority (sort { $a <=> $b } keys %by_code_priority) {
+ my %by_tag_name = %{$by_code_priority{$code_priority}};
+
+ for my $tag_name (sort keys %by_tag_name) {
+ my %by_context = %{$by_tag_name{$tag_name}};
+
+ for my $context (sort keys %by_context) {
+
+ my $hints
+ = $sorter{$override_status}{$code_priority}{$tag_name}
+ {$context};
+
+ push(@sorted, $_)for @{$hints};
+ }
+ }
+ }
+ }
+
+ my @hint_dictionaries;
+ for my $hint (@sorted) {
+
+ my $tag = $profile->get_tag($hint->tag_name);
+
+ my %hint_dictionary;
+ push(@hint_dictionaries, \%hint_dictionary);
+
+ $hint_dictionary{tag} = $tag->name;
+ $hint_dictionary{note} = $hint->note;
+
+ if ($hint->can('pointer')) {
+ my $pointer = $hint->pointer;
+
+ my %pointer_dictionary;
+
+ if ($pointer->can('item')) {
+ my $item = $pointer->item;
+
+ my %item_dictionary;
+ $item_dictionary{name} = $item->name;
+ $item_dictionary{index} = $item->index->identifier;
+
+ $pointer_dictionary{item} = \%item_dictionary;
+
+ # numerify to force JSON integer
+ # https://metacpan.org/pod/JSON::XS#simple-scalars
+ $pointer_dictionary{line_position} = $pointer->position + 0;
+ }
+
+ $hint_dictionary{pointer} = \%pointer_dictionary;
+ }
+
+ $hint_dictionary{visibility} = $tag->visibility;
+ $hint_dictionary{experimental}
+ = ($tag->experimental ? JSON()->true : JSON()->false);
+
+ for my $mask (@{ $hint->masks }) {
+
+ my %mask_dictionary;
+ $mask_dictionary{screen} = $mask->screen;
+ $mask_dictionary{excuse} = $mask->excuse;
+
+ push(@{$hint_dictionary{masks}}, \%mask_dictionary);
+ }
+
+ if ($hint->override) {
+
+ my %override_dictionary;
+ $override_dictionary{justification}
+ = $hint->override->justification;
+
+ $hint_dictionary{override} = \%override_dictionary;
+ }
+ }
+
+ return \@hint_dictionaries;
+}
+
+=item describe_tags
+
+=cut
+
+sub describe_tags {
+ my ($self, $data, $tags) = @_;
+
+ my @tag_dictionaries;
+
+ for my $tag (@{$tags}) {
+
+ my %tag_dictionary;
+ push(@tag_dictionaries, \%tag_dictionary);
+
+ $tag_dictionary{name} = $tag->name;
+ $tag_dictionary{name_spaced}
+ = ($tag->name_spaced ? JSON()->true : JSON()->false);
+ $tag_dictionary{show_always}
+ = ($tag->show_always ? JSON()->true : JSON()->false);
+
+ $tag_dictionary{explanation} = $tag->explanation;
+
+ my @tag_see_also_markdown
+ = map { markdown_citation($data, $_) } @{$tag->see_also};
+ $tag_dictionary{see_also} = \@tag_see_also_markdown;
+
+ $tag_dictionary{check} = $tag->check;
+ $tag_dictionary{visibility} = $tag->visibility;
+ $tag_dictionary{experimental}
+ = ($tag->experimental ? JSON()->true : JSON()->false);
+
+ $tag_dictionary{renamed_from} = $tag->renamed_from;
+
+ my @screen_dictionaries;
+
+ for my $screen (@{$tag->screens}) {
+
+ my %screen_dictionary;
+ push(@screen_dictionaries, \%screen_dictionary);
+
+ $screen_dictionary{name} = $screen->name;
+
+ my @advocate_emails = map { $_->format } @{$screen->advocates};
+ $screen_dictionary{advocates} = \@advocate_emails;
+
+ $screen_dictionary{reason} = $screen->reason;
+
+ my @screen_see_also_markdown
+ = map { markdown_citation($data, $_) } @{$screen->see_also};
+ $screen_dictionary{see_also} = \@screen_see_also_markdown;
+ }
+
+ $tag_dictionary{screens} = \@screen_dictionaries;
+
+ $tag_dictionary{lintian_version} = $ENV{LINTIAN_VERSION};
+ }
+
+ # convert to UTF-8 prior to encoding in JSON
+ my $encoder = JSON->new;
+ $encoder->canonical;
+ $encoder->utf8;
+ $encoder->pretty;
+
+ # encode single tags without array bracketing
+ my $object = \@tag_dictionaries;
+ $object = shift @tag_dictionaries
+ if @tag_dictionaries == 1;
+
+ my $json = $encoder->encode($object);
+
+ # output encoded JSON; is already in UTF-8
+ print $json;
+
+ return;
+}
+
+=back
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Output/Markdown.pm b/lib/Lintian/Output/Markdown.pm
new file mode 100644
index 0000000..5786612
--- /dev/null
+++ b/lib/Lintian/Output/Markdown.pm
@@ -0,0 +1,224 @@
+# -*- perl -*-
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Output::Markdown;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+our @EXPORT_OK = qw(
+ markdown_citation
+ markdown_authority
+ markdown_bug
+ markdown_manual_page
+ markdown_uri
+ markdown_hyperlink
+);
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+=head1 NAME
+
+Lintian::Output::Markdown - Lintian interface for markdown output
+
+=head1 SYNOPSIS
+
+ use Lintian::Output::Markdown;
+
+=head1 DESCRIPTION
+
+Lintian::Output::Markdown provides functions for Markdown output.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item markdown_citation
+
+=cut
+
+sub markdown_citation {
+ my ($data, $citation) = @_;
+
+ if ($citation =~ m{^ ([\w-]+) \s+ (.+) $}x) {
+
+ my $volume = $1;
+ my $section = $2;
+
+ my $markdown = $data->markdown_authority_reference($volume, $section);
+
+ $markdown ||= $citation;
+
+ return $markdown;
+ }
+
+ if ($citation =~ m{^ ([\w.-]+) [(] (\d\w*) [)] $}x) {
+
+ my $name = $1;
+ my $section = $2;
+
+ return markdown_manual_page($name, $section);
+ }
+
+ if ($citation =~ m{^(?:Bug)?#(\d+)$}) {
+
+ my $number = $1;
+ return markdown_bug($number);
+ }
+
+ # turn bare file into file uris
+ $citation =~ s{^ / }{file://}x;
+
+ # strip scheme from uri
+ if ($citation =~ s{^ (\w+) : // }{}x) {
+
+ my $scheme = $1;
+
+ return markdown_uri($scheme, $citation);
+ }
+
+ return $citation;
+}
+
+=item markdown_authority
+
+=cut
+
+sub markdown_authority {
+ my ($volume_title, $volume_url, $section_key, $section_title,$section_url)
+ = @_;
+
+ my $directed_link;
+ $directed_link = markdown_hyperlink($section_title, $section_url)
+ if length $section_title
+ && length $section_url;
+
+ my $pointer;
+ if (length $section_key) {
+
+ if ($section_key =~ /^[A-Z]+$/ || $section_key =~ /^appendix-/) {
+ $pointer = "Appendix $section_key";
+
+ } elsif ($section_key =~ /^\d+$/) {
+ $pointer = "Chapter $section_key";
+
+ } else {
+ $pointer = "Section $section_key";
+ }
+ }
+
+ # overall manual.
+ my $volume_link = markdown_hyperlink($volume_title, $volume_url);
+
+ if (length $directed_link) {
+
+ return "$directed_link ($pointer) in the $volume_title"
+ if length $pointer;
+
+ return "$directed_link in the $volume_title";
+ }
+
+ return "$pointer of the $volume_link"
+ if length $pointer;
+
+ return "the $volume_link";
+}
+
+=item markdown_bug
+
+=cut
+
+sub markdown_bug {
+ my ($number) = @_;
+
+ return markdown_hyperlink("Bug#$number","https://bugs.debian.org/$number");
+}
+
+=item markdown_manual_page
+
+=cut
+
+sub markdown_manual_page {
+ my ($name, $section) = @_;
+
+ my $url
+ ="https://manpages.debian.org/cgi-bin/man.cgi?query=$name&amp;sektion=$section";
+ my $hyperlink = markdown_hyperlink("$name($section)", $url);
+
+ return "the $hyperlink manual page";
+}
+
+=item markdown_uri
+
+=cut
+
+sub markdown_uri {
+ my ($scheme, $locator) = @_;
+
+ my $url = "$scheme://$locator";
+
+ # use plain path as label for files
+ return markdown_hyperlink($locator, $url)
+ if $scheme eq 'file';
+
+ # or nothing for everything else
+ return markdown_hyperlink($EMPTY, $url);
+}
+
+=item markdown_hyperlink
+
+=cut
+
+sub markdown_hyperlink {
+ my ($text, $url) = @_;
+
+ return $text
+ unless length $url;
+
+ return "<$url>"
+ unless length $text;
+
+ return "[$text]($url)";
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Output/Universal.pm b/lib/Lintian/Output/Universal.pm
new file mode 100644
index 0000000..a16da49
--- /dev/null
+++ b/lib/Lintian/Output/Universal.pm
@@ -0,0 +1,151 @@
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Output::Universal;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp;
+use Const::Fast;
+use List::SomeUtils qw(all);
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $SPACE => q{ };
+const my $COLON => q{:};
+const my $LEFT_PARENTHESIS => q{(};
+const my $RIGHT_PARENTHESIS => q{)};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Output::Universal -- Facilities for printing universal hints
+
+=head1 SYNOPSIS
+
+ use Lintian::Output::Universal;
+
+=head1 DESCRIPTION
+
+A class for printing hints using the 'universal' format.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item issue_hints
+
+Passing all groups with all processables in case no hints were found.
+
+=cut
+
+sub issue_hints {
+ my ($self, $profile, $groups) = @_;
+
+ for my $group (@{$groups // []}) {
+
+ my @by_group;
+ for my $processable ($group->get_processables) {
+
+ for my $hint (@{$processable->hints}) {
+
+ my $line
+ = $processable->name
+ . $SPACE
+ . $LEFT_PARENTHESIS
+ . $processable->type
+ . $RIGHT_PARENTHESIS
+ . $COLON
+ . $SPACE
+ . $hint->tag_name;
+
+ $line .= $SPACE . $hint->context
+ if length $hint->context;
+
+ push(@by_group, $line);
+ }
+ }
+
+ my @sorted
+ = reverse sort { order($a) cmp order($b) } @by_group;
+
+ say encode_utf8($_) for @sorted;
+ }
+
+ return;
+}
+
+=item order
+
+=cut
+
+sub order {
+ my ($line) = @_;
+
+ return package_type($line) . $line;
+}
+
+=item package_type
+
+=cut
+
+sub package_type {
+ my ($line) = @_;
+
+ my (undef, $type, undef, undef) = parse_line($line);
+ return $type;
+}
+
+=item parse_line
+
+=cut
+
+sub parse_line {
+ my ($line) = @_;
+
+ my ($package, $type, $name, $details)
+ = $line =~ qr/^(\S+)\s+\(([^)]+)\):\s+(\S+)(?:\s+(.*))?$/;
+
+ croak encode_utf8("Cannot parse line $line")
+ unless all { length } ($package, $type, $name);
+
+ return ($package, $type, $name, $details);
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Override.pm b/lib/Lintian/Override.pm
new file mode 100644
index 0000000..c62788d
--- /dev/null
+++ b/lib/Lintian/Override.pm
@@ -0,0 +1,86 @@
+# -*- perl -*- Lintian::Override
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Override;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+const my $EMPTY => q{};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Override - access to override data
+
+=head1 SYNOPSIS
+
+ use Lintian::Override;
+
+=head1 DESCRIPTION
+
+Lintian::Override provides access to override data.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item tag_name
+
+=item architectures
+
+=item pattern
+
+=item justification
+
+=item position
+
+=cut
+
+has tag_name => (is => 'rw', default => $EMPTY);
+has architectures => (is => 'rw', default => sub { [] });
+
+has pattern => (is => 'rw', default => $EMPTY);
+
+has justification => (is => 'rw', default => $EMPTY);
+has position => (is => 'rw');
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Pointer/Item.pm b/lib/Lintian/Pointer/Item.pm
new file mode 100644
index 0000000..6622fc8
--- /dev/null
+++ b/lib/Lintian/Pointer/Item.pm
@@ -0,0 +1,100 @@
+# Copyright (C) 2021 Felix Lechner <felix.lechner@lease-up.com>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Pointer::Item;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $COLON => q{:};
+
+=head1 NAME
+
+Lintian::Pointer::Item -- Facilities for pointing into specific index items
+
+=head1 SYNOPSIS
+
+use Lintian::Pointer::Item;
+
+=head1 DESCRIPTION
+
+A class for item pointers
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item item
+
+=item position
+
+=cut
+
+has item => (is => 'rw');
+has position => (
+ is => 'rw',
+ coerce => sub { my ($number) = @_; return $number // 0;},
+ default => 0
+);
+
+=item to_string
+
+=cut
+
+sub to_string {
+ my ($self) = @_;
+
+ croak encode_utf8('No item')
+ unless defined $self->item;
+
+ my $text = $self->item->name;
+
+ $text .= $COLON . $self->position
+ if $self->position > 0;
+
+ return $text;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Pool.pm b/lib/Lintian/Pool.pm
new file mode 100644
index 0000000..db153f9
--- /dev/null
+++ b/lib/Lintian/Pool.pm
@@ -0,0 +1,412 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+## Represents a pool of processables (Lintian::Processable)
+package Lintian::Pool;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd qw(getcwd);
+use List::SomeUtils qw(any);
+use Time::HiRes qw(gettimeofday tv_interval);
+use Path::Tiny;
+use POSIX qw(:sys_wait_h);
+use Proc::ProcessTable;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Group;
+
+const my $SPACE => q{ };
+const my $COMMA => q{,};
+const my $SEMICOLON => q{;};
+const my $LEFT_PARENS => q{(};
+const my $RIGHT_PARENS => q{)};
+const my $PLURAL_S => q{s};
+
+const my $ANY_CHILD => -1;
+const my $WORLD_WRITABLE_FOLDER => oct(777);
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Pool -- Pool of processables
+
+=head1 SYNOPSIS
+
+ use Lintian::Pool;
+
+ my $pool = Lintian::Pool->new;
+ $pool->add_file('foo.changes');
+ $pool->add_file('bar.dsc');
+ $pool->add_file('baz.deb');
+ $pool->add_file('qux.buildinfo');
+ foreach my $gname ($pool->get_group_names){
+ my $group = $pool->get_group($gname);
+ process($gname, $group);
+ }
+
+=head1 METHODS
+
+=over 4
+
+=item $pool->groups
+
+Returns a hash reference to the list of processable groups that are currently
+in the pool. The key is a unique identifier based on name and version.
+
+=item C<savedir>
+
+=cut
+
+has groups => (is => 'rw', default => sub{ {} });
+
+has savedir => (is => 'rw', default => sub{ getcwd; });
+
+# must be absolute; frontend/lintian depends on it
+has basedir => (
+ is => 'rw',
+ default => sub {
+
+ my $absolute
+ = Path::Tiny->tempdir(TEMPLATE => 'lintian-pool-XXXXXXXXXX');
+
+ $absolute->mkpath({mode => $WORLD_WRITABLE_FOLDER});
+
+ return $absolute;
+ }
+);
+
+=item $pool->basedir
+
+Returns the base directory for the pool. Most likely it's a temporary directory.
+
+=item $pool->add_group($group)
+
+Adds a group to the pool.
+
+=cut
+
+sub add_group {
+ my ($self, $group) = @_;
+
+ my $name = $group->name;
+
+ unless (exists $self->groups->{$name}){
+
+ # group does not exist; just add whole
+ $self->groups->{$name} = $group;
+
+ return 1;
+ }
+
+ # group exists; merge & accept all new
+ my $added = 0;
+
+ my $old = $self->groups->{$name};
+
+ for my $type (qw/source buildinfo changes/) {
+
+ if (!defined $old->$type && defined $group->$type) {
+ $old->add_processable($group->$type);
+ $added = 1;
+ }
+ }
+
+ for my $installable ($group->get_installables){
+ # New binary package ?
+ my $was_new = $old->add_processable($installable);
+ $added ||= $was_new;
+ }
+
+ return $added;
+}
+
+=item $pool->process
+
+Process the pool.
+
+=cut
+
+sub process{
+ my ($self, $PROFILE, $exit_code_ref, $option)= @_;
+
+ if ($self->empty) {
+ say {*STDERR} encode_utf8('No packages selected.');
+ return;
+ }
+
+ my %reported_count;
+ my %override_count;
+ my %ignored_overrides;
+ my $unused_overrides = 0;
+
+ for my $group (values %{$self->groups}) {
+
+ my $total_start = [gettimeofday];
+
+ $group->profile($PROFILE);
+ $group->jobs($option->{'jobs'});
+
+ my $success= $group->process(\%ignored_overrides, $option);
+
+ for my $processable ($group->get_processables){
+
+ my @keep;
+ for my $hint (@{$processable->hints}) {
+
+ my $tag = $PROFILE->get_tag($hint->tag_name);
+
+ # discard experimental tags
+ next
+ if $tag->experimental
+ && !$option->{'display-experimental'};
+
+ # discard overridden tags
+ next
+ if defined $hint->override
+ && !$option->{'show-overrides'};
+
+ # discard outside the selected display level
+ next
+ unless $PROFILE->display_level_for_tag($hint->tag_name);
+
+ if (!defined $hint->override) {
+
+ ++$reported_count{$tag->visibility}
+ if !$tag->experimental;
+
+ ++$reported_count{experimental}
+ if $tag->experimental;
+ }
+
+ ++$reported_count{override}
+ if defined $hint->override;
+
+ ++$unused_overrides
+ if $hint->tag_name eq 'unused-override'
+ || $hint->tag_name eq 'mismatched-override';
+
+ push(@keep, $hint);
+ }
+
+ $processable->hints(\@keep);
+ }
+
+ ${$exit_code_ref} = 2
+ if $success && any { $reported_count{$_} } @{$option->{'fail-on'}};
+
+ # interruptions can leave processes behind (manpages); wait and reap
+ if (${$exit_code_ref} == 1) {
+ 1 while waitpid($ANY_CHILD, WNOHANG) > 0;
+ }
+
+ if ($option->{debug}) {
+ my $process_table = Proc::ProcessTable->new;
+ my @leftover= grep { $_->ppid == $$ } @{$process_table->table};
+
+ # announce left over processes, see commit 3bbcc3b
+ if (@leftover) {
+ warn encode_utf8(
+ "\nSome processes were left over (maybe unreaped):\n");
+
+ my $FORMAT = ' %-12s %-12s %-8s %-24s %s';
+ say encode_utf8(
+ sprintf(
+ $FORMAT,'PID', 'TTY', 'STATUS', 'START', 'COMMAND'
+ )
+ );
+
+ say encode_utf8(
+ sprintf($FORMAT,
+ $_->pid,$_->ttydev,
+ $_->state,scalar(localtime($_->start)),
+ $_->cmndline)
+ )for @leftover;
+
+ ${$exit_code_ref} = 1;
+ die encode_utf8("Aborting.\n");
+ }
+ }
+
+ my $total_raw_res = tv_interval($total_start);
+ my $total_tres = sprintf('%.3fs', $total_raw_res);
+
+ my $status = $success ? 'complete' : 'error';
+ say {*STDERR}
+ encode_utf8($status . $SPACE . $group->name . " ($total_tres)")
+ if $option->{'status-log'};
+ say {*STDERR} encode_utf8('Finished processing group ' . $group->name)
+ if $option->{debug};
+
+ ${$exit_code_ref} = 1
+ unless $success;
+ }
+
+ my $OUTPUT;
+ if ($option->{'output-format'} eq 'html') {
+ require Lintian::Output::HTML;
+ $OUTPUT = Lintian::Output::HTML->new;
+ } elsif ($option->{'output-format'} eq 'json') {
+ require Lintian::Output::JSON;
+ $OUTPUT = Lintian::Output::JSON->new;
+ } elsif ($option->{'output-format'} eq 'universal') {
+ require Lintian::Output::Universal;
+ $OUTPUT = Lintian::Output::Universal->new;
+ } else {
+ require Lintian::Output::EWI;
+ $OUTPUT = Lintian::Output::EWI->new;
+ }
+
+ # pass everything, in case some groups or processables have no hints
+ $OUTPUT->issue_hints($PROFILE, [values %{$self->groups}], $option);
+
+ my $errors = $override_count{error} // 0;
+ my $warnings = $override_count{warning} // 0;
+ my $info = $override_count{info} // 0;
+ my $total = $errors + $warnings + $info;
+
+ if ( $option->{'output-format'} eq 'ewi'
+ && !$option->{'no-override'}
+ && !$option->{'show-overrides'}
+ && ($total > 0 || $unused_overrides > 0)) {
+
+ my @details;
+ push(@details, quantity($errors, 'error'))
+ if $errors;
+ push(@details, quantity($warnings, 'warning'))
+ if $warnings;
+ push(@details, "$info info")
+ if $info;
+
+ my $text = quantity($total, 'hint') . ' overridden';
+ $text
+ .= $SPACE
+ . $LEFT_PARENS
+ . join($COMMA . $SPACE, @details)
+ . $RIGHT_PARENS
+ if @details;
+ $text
+ .= $SEMICOLON
+ . $SPACE
+ . quantity($unused_overrides, 'unused override');
+
+ say encode_utf8("N: $text");
+ }
+
+ if ($option->{'output-format'} eq 'ewi' && %ignored_overrides) {
+ say encode_utf8('N: Some overrides were ignored.');
+
+ if ($option->{verbose}) {
+ say encode_utf8(
+'N: The following tags had at least one override but are mandatory:'
+ );
+ say encode_utf8("N: - $_") for sort keys %ignored_overrides;
+
+ } else {
+ say encode_utf8('N: Use --verbose for more information.');
+ }
+ }
+
+ path($self->basedir)->remove_tree
+ if length $self->basedir && -d $self->basedir;
+
+ return;
+}
+
+=item quantity
+
+=cut
+
+sub quantity {
+ my ($count, $unit) = @_;
+
+ my $text = $count . $SPACE . $unit;
+ $text .= $PLURAL_S
+ unless $count == 1;
+
+ return $text;
+}
+
+=item $pool->get_group_names
+
+Returns the name of all the groups in this pool.
+
+Do not modify the list nor its contents.
+
+=cut
+
+sub get_group_names{
+ my ($self) = @_;
+
+ return keys %{ $self->groups };
+}
+
+=item $pool->get_group($name)
+
+Returns the group called $name or C<undef>
+if there is no group called $name.
+
+=cut
+
+sub get_group{
+ my ($self, $group) = @_;
+
+ return $self->groups->{$group};
+}
+
+=item $pool->empty
+
+Returns true if the pool is empty.
+
+=cut
+
+sub empty{
+ my ($self) = @_;
+
+ return scalar keys %{$self->groups} == 0;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable>
+
+L<Lintian::Group>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable.pm b/lib/Lintian/Processable.pm
new file mode 100644
index 0000000..c89a1fc
--- /dev/null
+++ b/lib/Lintian/Processable.pm
@@ -0,0 +1,302 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Processable;
+
+use v5.20;
+use warnings;
+use utf8;
+use warnings::register;
+
+use Const::Fast;
+use File::Basename;
+use Path::Tiny;
+
+use Moo::Role;
+use MooX::Aliases;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $COLON => q{:};
+const my $SLASH => q{/};
+const my $UNDERSCORE => q{_};
+const my $EVIL_CHARACTERS => qr{[/&|;\$"'<>]};
+
+=encoding utf-8
+
+=head1 NAME
+
+Lintian::Processable -- An (abstract) object that Lintian can process
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Instances of this perl class are objects that Lintian can process (e.g.
+deb files). Multiple objects can then be combined into
+L<groups|Lintian::Group>, which Lintian will process
+together.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item name
+
+Returns the name of the package.
+
+=item type
+
+Returns the type of package (e.g. binary, source, udeb ...)
+
+=item hints
+
+=item $proc->version
+
+Returns the version of the package.
+
+=item $proc->path
+
+Returns the path to the packaged version of actual package. This path
+is used in case the data needs to be extracted from the package.
+
+=item basename
+
+Returns the basename of the package path.
+
+=item $proc->architecture
+
+Returns the architecture(s) of the package. May return multiple values
+from changes processables. For source processables it is "source".
+
+=item $proc->source_name
+
+Returns the name of the source package.
+
+=item $proc->source_version
+
+Returns the version of the source package.
+
+=item $proc->tainted
+
+Returns a truth value if one or more fields in this Processable is
+tainted. On a best effort basis tainted fields will be sanitized
+to less dangerous (but possibly invalid) values.
+
+=item fields
+
+Lintian::Deb822::Section with primary field values.
+
+=item $proc->pooldir
+
+Returns a reference to lab this Processable is in.
+
+=item $proc->basedir
+
+Returns the base directory of this package inside the lab.
+
+=cut
+
+has path => (
+ is => 'rw',
+ default => $EMPTY,
+ trigger => sub {
+ my ($self, $path) = @_;
+
+ my $basename = basename($path);
+ $self->basename($basename);
+ }
+);
+has basename => (is => 'rw', default => $EMPTY);
+has type => (is => 'rw', default => $EMPTY);
+
+has hints => (is => 'rw', default => sub { [] });
+
+has architecture => (
+ is => 'rw',
+ coerce => sub {
+ my ($value) = @_;
+ return clean_field($value);
+ },
+ default => $EMPTY
+);
+has name => (
+ is => 'rw',
+ coerce => sub {
+ my ($value) = @_;
+ return clean_field($value);
+ },
+ default => $EMPTY
+);
+has source_name => (
+ is => 'rw',
+ coerce => sub {
+ my ($value) = @_;
+ return clean_field($value);
+ },
+ default => $EMPTY
+);
+has source_version =>(
+ is => 'rw',
+ coerce => sub {
+ my ($value) = @_;
+ return clean_field($value);
+ },
+ default => $EMPTY
+);
+has version => (
+ is => 'rw',
+ coerce => sub {
+ my ($value) = @_;
+ return clean_field($value);
+ },
+ default => $EMPTY
+);
+
+has tainted => (is => 'rw', default => 0);
+
+has fields => (is => 'rw', default => sub { Lintian::Deb822::Section->new; });
+
+has pooldir => (is => 'rw', default => $EMPTY);
+has basedir => (
+ is => 'rw',
+ lazy => 1,
+ trigger => sub {
+ my ($self, $folder) = @_;
+
+ return
+ unless length $folder;
+
+ # create directory
+ path($folder)->mkpath
+ unless -e $folder;
+ },
+ default => sub {
+ my ($self) = @_;
+
+ my $path
+ = $self->source_name
+ . $SLASH
+ . $self->name
+ . $UNDERSCORE
+ . $self->version;
+ $path .= $UNDERSCORE . $self->architecture
+ unless $self->type eq 'source';
+ $path .= $UNDERSCORE . $self->type;
+
+ # architectures can contain spaces in changes files
+ $path =~ s/\s/-/g;
+
+ # colon can be a path separator
+ $path =~ s/:/_/g;
+
+ my $basedir = $self->pooldir . "/$path";
+
+ return $basedir;
+ }
+);
+
+=item C<identifier>
+
+Produces an identifier for this processable. The identifier is
+based on the type, name, version and architecture of the package.
+
+=cut
+
+sub identifier {
+ my ($self) = @_;
+
+ my $id = $self->type . $COLON . $self->name . $UNDERSCORE . $self->version;
+
+ # add architecture unless it is source
+ $id .= $UNDERSCORE . $self->architecture
+ unless $self->type eq 'source';
+
+ $id =~ s/\s+/_/g;
+
+ return $id;
+}
+
+=item clean_field
+
+Cleans a field of evil characters to prevent traversal or worse.
+
+=cut
+
+sub clean_field {
+ my ($value) = @_;
+
+ # make sure none of the fields can cause traversal
+ my $clean = $value;
+ $clean =~ s/${$EVIL_CHARACTERS}/_/g;
+
+ return $clean;
+}
+
+=item guess_name
+
+=cut
+
+sub guess_name {
+ my ($self, $path) = @_;
+
+ my $guess = path($path)->basename;
+
+ # drop extension, to catch fields-general-missing.deb
+ $guess =~ s/\.[^.]*$//;
+
+ # drop everything after the first underscore, if any
+ $guess =~ s/_.*$//;
+
+ # 'path/lintian_2.5.2_amd64.changes' became 'lintian'
+ return $guess;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+Substantial portions written by Russ Allbery <rra@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable::Installable>
+
+L<Lintian::Processable::Buildinfo>
+
+L<Lintian::Processable::Changes>
+
+L<Lintian::Processable::Source>
+
+L<Lintian::Group>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Buildinfo.pm b/lib/Lintian/Processable/Buildinfo.pm
new file mode 100644
index 0000000..f5983fa
--- /dev/null
+++ b/lib/Lintian/Processable/Buildinfo.pm
@@ -0,0 +1,133 @@
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Processable::Buildinfo;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+with
+ 'Lintian::Processable',
+ 'Lintian::Processable::Fields::Files',
+ 'Lintian::Processable::Buildinfo::Overrides';
+
+=for Pod::Coverage BUILDARGS
+
+=head1 NAME
+
+Lintian::Processable::Buildinfo -- A buildinfo file Lintian can process
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable::Buildinfo;
+
+ my $processable = Lintian::Processable::Buildinfo->new;
+ $processable->init_from_file('path');
+
+=head1 DESCRIPTION
+
+This class represents a 'buildinfo' file that Lintian can process. Objects
+of this kind are often part of a L<Lintian::Group>, which
+represents all the files in a changes or buildinfo file.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item init_from_file (PATH)
+
+Initializes a new object from PATH.
+
+=cut
+
+sub init_from_file {
+ my ($self, $file) = @_;
+
+ croak encode_utf8("File $file does not exist")
+ unless -e $file;
+
+ $self->path($file);
+ $self->type('buildinfo');
+
+ my $primary = Lintian::Deb822->new;
+ my @sections = $primary->read_file($self->path)
+ or croak encode_utf8(
+ $self->path. ' is not a valid '. $self->type . ' file');
+
+ $self->fields($sections[0]);
+
+ my $name = $self->fields->value('Source');
+ my $version = $self->fields->value('Version');
+ my $architecture = $self->fields->value('Architecture');
+
+ unless (length $name) {
+ $name = $self->guess_name($self->path);
+ croak encode_utf8('Cannot determine the name from '. $self->path)
+ unless length $name;
+ }
+
+ my $source_name = $name;
+ my $source_version = $version;
+
+ $self->name($name);
+ $self->version($version);
+ $self->architecture($architecture);
+ $self->source_name($source_name);
+ $self->source_version($source_version);
+
+ # make sure none of these fields can cause traversal
+ $self->tainted(1)
+ if $self->name ne $name
+ || $self->version ne $version
+ || $self->architecture ne $architecture
+ || $self->source_name ne $source_name
+ || $self->source_version ne $source_version;
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Buildinfo/Overrides.pm b/lib/Lintian/Processable/Buildinfo/Overrides.pm
new file mode 100644
index 0000000..136c01c
--- /dev/null
+++ b/lib/Lintian/Processable/Buildinfo/Overrides.pm
@@ -0,0 +1,94 @@
+# -*- perl -*- Lintian::Processable::Buildinfo::Overrides
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Buildinfo::Overrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+with 'Lintian::Processable::Overrides';
+
+=head1 NAME
+
+Lintian::Processable::Buildinfo::Overrides - access to override data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Buildinfo::Overrides provides an interface for overrides.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item override_file
+
+=cut
+
+has override_file => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return undef;
+ }
+);
+
+=item overrides
+
+=cut
+
+has overrides => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @overrides;
+
+ return \@overrides;
+ }
+);
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Changelog/Version.pm b/lib/Lintian/Processable/Changelog/Version.pm
new file mode 100644
index 0000000..7721b17
--- /dev/null
+++ b/lib/Lintian/Processable/Changelog/Version.pm
@@ -0,0 +1,108 @@
+# -*- perl -*-
+# Lintian::Processable::Changelog::Version -- interface to source package data collection
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Changelog::Version;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Syntax::Keyword::Try;
+
+use Lintian::Changelog::Version;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Changelog::Version - Lintian interface to source package data collection
+
+=head1 SYNOPSIS
+
+ my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry');
+ my $collect = Lintian::Processable::Changelog::Version->new($name);
+ if ($collect->native) {
+ print "Package is native\n";
+ }
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Changelog::Version provides an interface to package data for source
+packages. It implements data collection methods specific to source
+packages.
+
+This module is in its infancy. Most of Lintian still reads all data from
+files in the laboratory whenever that data is needed and generates that
+data via collect scripts. The goal is to eventually access all data about
+source packages via this module so that the module can cache data where
+appropriate and possibly retire collect scripts in favor of caching that
+data in memory.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item changelog_version
+
+Returns a fully parsed Lintian::Changelog::Version for the
+source package's version string.
+
+=cut
+
+has changelog_version => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $versionstring = $self->fields->value('Version');
+
+ my $version = Lintian::Changelog::Version->new;
+ try {
+ $version->assign($versionstring, $self->native);
+
+ } catch {
+ }
+
+ return $version;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Changes.pm b/lib/Lintian/Processable/Changes.pm
new file mode 100644
index 0000000..65eb8e4
--- /dev/null
+++ b/lib/Lintian/Processable/Changes.pm
@@ -0,0 +1,145 @@
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Processable::Changes;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Path::Tiny;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+with
+ 'Lintian::Processable',
+ 'Lintian::Processable::Fields::Files',
+ 'Lintian::Processable::Changes::Overrides';
+
+=for Pod::Coverage BUILDARGS
+
+=head1 NAME
+
+Lintian::Processable::Changes -- A changes file Lintian can process
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable::Changes;
+
+ my $processable = Lintian::Processable::Changes->new;
+ $processable->init_from_file('path');
+
+=head1 DESCRIPTION
+
+This class represents a 'changes' file that Lintian can process. Objects
+of this kind are often part of a L<Lintian::Group>, which
+represents all the files in a changes or buildinfo file.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item init_from_file (PATH)
+
+Initializes a new object from PATH.
+
+=cut
+
+sub init_from_file {
+ my ($self, $file) = @_;
+
+ croak encode_utf8("File $file does not exist")
+ unless -e $file;
+
+ $self->path($file);
+ $self->type('changes');
+
+ # dpkg will include news items in national encoding
+ my $bytes = path($self->path)->slurp;
+
+ my $contents;
+ if (valid_utf8($bytes)) {
+ $contents = decode_utf8($bytes);
+ } else {
+ # try to proceed with nat'l encoding; stopping here breaks tests
+ $contents = $bytes;
+ }
+
+ my $primary = Lintian::Deb822->new;
+ my @sections = $primary->parse_string($contents)
+ or croak encode_utf8(
+ $self->path. ' is not a valid '. $self->type . ' file');
+
+ $self->fields($sections[0]);
+
+ my $name = $self->fields->value('Source');
+ my $version = $self->fields->value('Version');
+ my $architecture = $self->fields->value('Architecture');
+
+ unless (length $name) {
+ $name = $self->guess_name($self->path);
+ croak encode_utf8('Cannot determine the name from ' . $self->path)
+ unless length $name;
+ }
+
+ my $source_name = $name;
+ my $source_version = $version;
+
+ $self->name($name);
+ $self->version($version);
+ $self->architecture($architecture);
+ $self->source_name($source_name);
+ $self->source_version($source_version);
+
+ # make sure none of these fields can cause traversal
+ $self->tainted(1)
+ if $self->name ne $name
+ || $self->version ne $version
+ || $self->architecture ne $architecture
+ || $self->source_name ne $source_name
+ || $self->source_version ne $source_version;
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Changes/Overrides.pm b/lib/Lintian/Processable/Changes/Overrides.pm
new file mode 100644
index 0000000..78bd04d
--- /dev/null
+++ b/lib/Lintian/Processable/Changes/Overrides.pm
@@ -0,0 +1,94 @@
+# -*- perl -*- Lintian::Processable::Changes::Overrides
+#
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Changes::Overrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+with 'Lintian::Processable::Overrides';
+
+=head1 NAME
+
+Lintian::Processable::Changes::Overrides - access to override data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Changes::Overrides provides an interface for overrides.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item override_file
+
+=cut
+
+has override_file => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return undef;
+ }
+);
+
+=item overrides
+
+=cut
+
+has overrides => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @overrides;
+
+ return \@overrides;
+ }
+);
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Debian/Control.pm b/lib/Lintian/Processable/Debian/Control.pm
new file mode 100644
index 0000000..a4c1cf9
--- /dev/null
+++ b/lib/Lintian/Processable/Debian/Control.pm
@@ -0,0 +1,90 @@
+# -*- perl -*-
+# Lintian::Processable::Debian::Control -- interface to source package data collection
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Debian::Control;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Debian::Control;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Debian::Control - Lintian interface to d/control fields
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Debian::Control provides an interface to package data
+from d/control.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item debian_control
+
+=cut
+
+has debian_control => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $control = Lintian::Debian::Control->new;
+
+ my $item = $self->patched->resolve_path('debian/control');
+ return $control
+ unless defined $item;
+
+ $control->load($item);
+
+ return $control;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Diffstat.pm b/lib/Lintian/Processable/Diffstat.pm
new file mode 100644
index 0000000..82a3b28
--- /dev/null
+++ b/lib/Lintian/Processable/Diffstat.pm
@@ -0,0 +1,162 @@
+# -*- perl -*- Lintian::Processable::Diffstat -- access to collected diffstat data
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Diffstat;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use IPC::Run3;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $COLON => q{:};
+const my $UNDERSCORE => q{_};
+const my $NEWLINE => qq{\n};
+
+const my $OPEN_PIPE => q{-|};
+const my $WAIT_STATUS_SHIFT => 8;
+
+=head1 NAME
+
+Lintian::Processable::Diffstat - access to collected diffstat data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Diffstat provides an interface to diffstat data.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item diffstat
+
+Returns the path to diffstat output run on the Debian packaging diff
+(a.k.a. the "diff.gz") for 1.0 non-native packages. For source
+packages without a "diff.gz" component, this returns the path to an
+empty file (this may be a device like /dev/null).
+
+=cut
+
+has diffstat => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $noepoch = $self->fields->value('Version');
+
+ # strip epoch
+ $noepoch =~ s/^\d://;
+
+ # look for a format 1.0 diff.gz near the input file
+ my $diffname = $self->name . $UNDERSCORE . $noepoch . '.diff.gz';
+ return {}
+ unless exists $self->files->{$diffname};
+
+ my $diffpath = path($self->path)->parent->child($diffname)->stringify;
+ return {}
+ unless -e $diffpath;
+
+ my @gunzip_command = ('gunzip', '--stdout', $diffpath);
+ my $gunzip_pid = open(my $from_gunzip, $OPEN_PIPE, @gunzip_command)
+ or die encode_utf8("Cannot run @gunzip_command: $!");
+
+ my $stdout;
+ my $stderr;
+ my @diffstat_command = qw(diffstat -p1);
+ run3(\@diffstat_command, $from_gunzip, \$stdout, \$stderr);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ $stdout = decode_utf8($stdout)
+ if length $stdout;
+ $stderr = decode_utf8($stderr)
+ if length $stderr;
+
+ if ($status) {
+
+ my $message= "Non-zero status $status from @diffstat_command";
+ $message .= $COLON . $NEWLINE . $stderr
+ if length $stderr;
+
+ die encode_utf8($message);
+ }
+
+ close $from_gunzip
+ or
+ warn encode_utf8("close failed for handle from @gunzip_command: $!");
+
+ waitpid($gunzip_pid, 0);
+
+ # remove summary in last line
+ chomp $stdout;
+ $stdout =~ s/.*\Z//;
+
+ my %diffstat;
+
+ my @lines = split(/\n/, $stdout);
+ for my $line (@lines) {
+
+ next
+ unless $line =~ s/\|\s*([^|]*)\s*$//;
+
+ my $stats = $1;
+ my $file = $line;
+
+ # trim both ends
+ $file =~ s/^\s+|\s+$//g;
+
+ die encode_utf8("syntax error in diffstat file: $line")
+ unless length $file;
+
+ $diffstat{$file} = $stats;
+ }
+
+ return \%diffstat;
+ }
+);
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Fields/Files.pm b/lib/Lintian/Processable/Fields/Files.pm
new file mode 100644
index 0000000..df21352
--- /dev/null
+++ b/lib/Lintian/Processable/Fields/Files.pm
@@ -0,0 +1,181 @@
+# -*- perl -*-
+# Lintian::Processable::Fields::Files -- interface to .buildinfo file data collection
+#
+# Copyright (C) 2010 Adam D. Barratt
+# Copyright (C) 2018 Chris Lamb
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Fields::Files;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Fields::Files - Lintian interface to .buildinfo or changes file data collection
+
+=head1 SYNOPSIS
+
+ use Moo;
+
+ with 'Lintian::Processable::Fields::Files';
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Fields::Files provides an interface to data for .buildinfo
+and changes files. It implements data collection methods specific to .buildinfo
+and changes files.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item files
+
+Returns a reference to a hash containing information about files listed
+in the .buildinfo file. Each hash may have the following keys:
+
+=over 4
+
+=item name
+
+Name of the file.
+
+=item size
+
+The size of the file in bytes.
+
+=item section
+
+The archive section to which the file belongs.
+
+=item priority
+
+The priority of the file.
+
+=item checksums
+
+A hash with the keys being checksum algorithms and the values themselves being
+hashes containing
+
+=over 4
+
+=item sum
+
+The result of applying the given algorithm to the file.
+
+=item filesize
+
+The size of the file as given in the .buildinfo section relating to the given
+checksum.
+
+=back
+
+=back
+
+=cut
+
+has files => (
+ is => 'rw',
+ lazy => 1,
+ default =>
+
+ sub {
+ my ($self) = @_;
+
+ my %files;
+
+ my @files_lines = split(/\n/, $self->fields->value('Files'));
+
+ # trim both ends of each line
+ s/^\s+|\s+$//g for @files_lines;
+
+ for my $line (grep { length } @files_lines) {
+
+ my @fields = split(/\s+/, $line);
+ my $basename = $fields[-1];
+
+ # ignore traversals
+ next
+ if $basename =~ m{/};
+
+ my ($md5sum, $size, $section, $priority) = @fields;
+
+ $files{$basename}{checksums}{Md5} = {
+ 'sum' => $md5sum,
+ 'filesize' => $size,
+ };
+
+ $files{$basename}{name} = $basename;
+ $files{$basename}{size} = $size;
+
+ unless ($self->type eq 'source') {
+
+ $files{$basename}{section} = $section;
+ $files{$basename}{priority} = $priority;
+ }
+ }
+
+ for my $algorithm (qw(Sha1 Sha256)) {
+
+ my @lines
+ = split(/\n/, $self->fields->value("Checksums-$algorithm"));
+
+ # trim both ends of each line
+ s/^\s+|\s+$//g for @lines;
+
+ for my $line (grep { length } @lines) {
+
+ my ($checksum, $size, $basename) = split(/\s+/, $line);
+
+ # ignore traversals
+ next
+ if $basename =~ m{/};
+
+ $files{$basename}{checksums}{$algorithm} = {
+ 'sum' => $checksum,
+ 'filesize' => $size
+ };
+ }
+ }
+
+ return \%files;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Adam D. Barratt <adsb@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1), L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Hardening.pm b/lib/Lintian/Processable/Hardening.pm
new file mode 100644
index 0000000..4bf24bd
--- /dev/null
+++ b/lib/Lintian/Processable/Hardening.pm
@@ -0,0 +1,105 @@
+# -*- perl -*- Lintian::Processable::Hardening
+#
+# Copyright (C) 2019 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Hardening;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Hardening - access to collected hardening data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Hardening provides an interface to collected hardening data.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item hardening_info
+
+Returns a hashref mapping a FILE to its hardening issues.
+
+NB: This is generally only useful for checks/binaries to emit the
+hardening-no-* tags.
+
+=cut
+
+sub hardening_info {
+ my ($self) = @_;
+
+ return $self->{hardening_info}
+ if exists $self->{hardening_info};
+
+ my $hardf = path($self->basedir)->child('hardening-info')->stringify;
+
+ my %hardening_info;
+
+ if (-e $hardf) {
+ open(my $idx, '<:utf8_strict', $hardf)
+ or die encode_utf8("Cannot open $hardf");
+
+ while (my $line = <$idx>) {
+ chomp($line);
+
+ if ($line =~ m{^([^:]+):(?:\./)?(.*)$}) {
+ my ($tag, $file) = ($1, $2);
+
+ push(@{$hardening_info{$file}}, $tag);
+ }
+ }
+ close($idx);
+ }
+
+ $self->{hardening_info} = \%hardening_info;
+
+ return $self->{hardening_info};
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable.pm b/lib/Lintian/Processable/Installable.pm
new file mode 100644
index 0000000..54ae406
--- /dev/null
+++ b/lib/Lintian/Processable/Installable.pm
@@ -0,0 +1,201 @@
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Processable::Installable;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use IPC::Run3;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8 valid_utf8);
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+with
+ 'Lintian::Processable',
+ 'Lintian::Processable::Installable::Changelog',
+ 'Lintian::Processable::Installable::Class',
+ 'Lintian::Processable::Installable::Conffiles',
+ 'Lintian::Processable::Installable::Control',
+ 'Lintian::Processable::Installable::Installed',
+ 'Lintian::Processable::Installable::Overrides',
+ 'Lintian::Processable::Installable::Relation',
+ 'Lintian::Processable::IsNonFree',
+ 'Lintian::Processable::Hardening',
+ 'Lintian::Processable::NotJustDocs';
+
+# read up to 40kB at a time. this happens to be 4096 "tar records"
+# (with a block-size of 512 and a block factor of 20, which appear to
+# be the defaults). when we do full reads and writes of READ_SIZE (the
+# OS willing), the receiving end will never be with an incomplete
+# record.
+const my $TAR_RECORD_SIZE => 20 * 512;
+
+const my $COLON => q{:};
+const my $NEWLINE => qq{\n};
+const my $OPEN_PIPE => q{-|};
+
+const my $WAIT_STATUS_SHIFT => 8;
+
+=for Pod::Coverage BUILDARGS
+
+=head1 NAME
+
+Lintian::Processable::Installable -- An installation package Lintian can process
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable::Installable;
+
+ my $processable = Lintian::Processable::Installable->new;
+ $processable->init_from_file('path');
+
+=head1 DESCRIPTION
+
+This class represents a 'deb' or 'udeb' file that Lintian can process. Objects
+of this kind are often part of a L<Lintian::Group>, which
+represents all the files in a changes or buildinfo file.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item init_from_file (PATH)
+
+Initializes a new object from PATH.
+
+=cut
+
+sub init_from_file {
+ my ($self, $file) = @_;
+
+ croak encode_utf8("File $file does not exist")
+ unless -e $file;
+
+ $self->path($file);
+
+ # get control.tar.gz; dpkg-deb -f $file is slow; use tar instead
+ my @dpkg_command = ('dpkg-deb', '--ctrl-tarfile', $self->path);
+
+ my $dpkg_pid = open(my $from_dpkg, $OPEN_PIPE, @dpkg_command)
+ or die encode_utf8("Cannot run @dpkg_command: $!");
+
+ # would like to set buffer size to 4096 & $TAR_RECORD_SIZE
+
+ # get binary control file
+ my $stdout_bytes;
+ my $stderr_bytes;
+ my @tar_command = qw{tar --wildcards -xO -f - *control};
+ run3(\@tar_command, $from_dpkg, \$stdout_bytes, \$stderr_bytes);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ if ($status) {
+
+ my $message= "Non-zero status $status from @tar_command";
+ $message .= $COLON . $NEWLINE . decode_utf8($stderr_bytes)
+ if length $stderr_bytes;
+
+ croak encode_utf8($message);
+ }
+
+ close $from_dpkg
+ or warn encode_utf8("close failed for handle from @dpkg_command: $!");
+
+ waitpid($dpkg_pid, 0);
+
+ croak encode_utf8('Nationally encoded control data in ' . $self->path)
+ unless valid_utf8($stdout_bytes);
+
+ my $stdout = decode_utf8($stdout_bytes);
+
+ my $deb822 = Lintian::Deb822->new;
+ my @sections = $deb822->parse_string($stdout);
+ croak encode_utf8(
+ 'Not exactly one section with installable control data in '
+ . $self->path)
+ unless @sections == 1;
+
+ $self->fields($sections[0]);
+
+ my $name = $self->fields->value('Package');
+ my $version = $self->fields->value('Version');
+ my $architecture = $self->fields->value('Architecture');
+ my $source_name = $self->fields->value('Source');
+
+ my $source_version = $version;
+
+ unless (length $name) {
+ $name = $self->guess_name($self->path);
+ croak encode_utf8('Cannot determine the name from ' . $self->path)
+ unless length $name;
+ }
+
+ # source may be left out if same as $name
+ $source_name = $name
+ unless length $source_name;
+
+ # source probably contains the version in parentheses
+ if ($source_name =~ m/(\S++)\s*\(([^\)]+)\)/){
+ $source_name = $1;
+ $source_version = $2;
+ }
+
+ $self->name($name);
+ $self->version($version);
+ $self->architecture($architecture);
+ $self->source_name($source_name);
+ $self->source_version($source_version);
+
+ # make sure none of these fields can cause traversal
+ $self->tainted(1)
+ if $self->name ne $name
+ || $self->version ne $version
+ || $self->architecture ne $architecture
+ || $self->source_name ne $source_name
+ || $self->source_version ne $source_version;
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable/Changelog.pm b/lib/Lintian/Processable/Installable/Changelog.pm
new file mode 100644
index 0000000..c43a17b
--- /dev/null
+++ b/lib/Lintian/Processable/Installable/Changelog.pm
@@ -0,0 +1,151 @@
+# -*- perl -*- Lintian::Processable::Installable::Changelog -- access to collected changelog data
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Installable::Changelog;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use File::Copy qw(copy);
+use List::SomeUtils qw(first_value);
+use Path::Tiny;
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Installable::Changelog - access to collected changelog data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Installable::Changelog provides an interface to changelog data.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item changelog_item
+
+=cut
+
+has changelog_item => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my @candidate_names = (
+ 'changelog.Debian.gz','changelog.Debian',
+ 'changelog.debian.gz','changelog.debian',
+ 'changelog.gz','changelog',
+ );
+
+ my $package_path = 'usr/share/doc/' . $self->name;
+ my @candidate_items = grep { defined }
+ map { $self->installed->lookup("$package_path/$_") }@candidate_names;
+
+ # pick the first existing file
+ my $item
+ = first_value { $_->is_file || length $_->link } @candidate_items;
+
+ return $item;
+ }
+);
+
+=item changelog
+
+For binary:
+
+Returns the changelog of the binary package as a Parse::DebianChangelog
+object, or an empty object if the changelog doesn't exist. The changelog-file
+collection script must have been run to create the changelog file, which
+this method expects to find in F<changelog>.
+
+=cut
+
+has changelog => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $changelog = Lintian::Changelog->new;
+
+ my $unresolved = $self->changelog_item;
+ return $changelog
+ unless defined $unresolved;
+
+ # stop for dangling symbolic link
+ my $item = $unresolved->resolve_path;
+ return $changelog
+ unless defined $item;
+
+ # return empty changelog
+ return $changelog
+ unless $item->is_file && $item->is_open_ok;
+
+ if ($item->basename =~ m{ [.]gz $}x) {
+
+ my $bytes = safe_qx('gunzip', '-c', $item->unpacked_path);
+
+ return $changelog
+ unless valid_utf8($bytes);
+
+ $changelog->parse(decode_utf8($bytes));
+
+ return $changelog;
+ }
+
+ return $changelog
+ unless $item->is_valid_utf8;
+
+ $changelog->parse($item->decoded_utf8);
+
+ return $changelog;
+ }
+);
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable/Class.pm b/lib/Lintian/Processable/Installable/Class.pm
new file mode 100644
index 0000000..00520be
--- /dev/null
+++ b/lib/Lintian/Processable/Installable/Class.pm
@@ -0,0 +1,139 @@
+# -*- perl -*-
+# Lintian::Processable::Installable::Class -- interface to binary package data collection
+
+# Copyright (C) 2008, 2009 Russ Allbery
+# Copyright (C) 2008 Frank Lichtenheld
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Installable::Class;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Installable::Class - Lintian interface to binary package data collection
+
+=head1 SYNOPSIS
+
+ my ($name, $type, $dir) = ('foobar', 'binary', '/path/to/lab-entry');
+ my $collect = Lintian::Processable::Installable::Class->new($name);
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Installable::Class provides an interface to package data for binary
+packages.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item is_debug_package
+
+The package probably contains only debug symbols.
+
+=cut
+
+sub is_debug_package {
+ my ($self) = @_;
+
+ return 1
+ if $self->name =~ /-dbg(?:sym)?/;
+
+ return 0;
+}
+
+=item is_auto_generated
+
+The package was probably generated automatically.
+
+=cut
+
+sub is_auto_generated {
+ my ($self) = @_;
+
+ return 1
+ if $self->fields->declares('Auto-Built-Package');
+
+ return 0;
+}
+
+=item is_transitional
+
+The package is probably transitional, i.e. it probably depends
+ on stuff will eventually disappear.
+
+=cut
+
+sub is_transitional {
+ my ($self) = @_;
+
+ return 1
+ if $self->fields->value('Description') =~ /transitional package/i;
+
+ return 0;
+}
+
+=item is_meta_package
+
+This package is probably some kind of meta or task package. A meta
+package is usually empty and just depend on stuff. It also returns
+a true value for "tasks" (i.e. tasksel "tasks").
+
+=cut
+
+sub is_meta_package {
+ my ($self) = @_;
+
+ return 1
+ if $self->fields->value('Description')
+ =~ /meta[ -]?package|(?:dependency|dummy|empty) package/i;
+
+ # section "tasks" or "metapackages" qualifies too
+ return 1
+ if $self->fields->value('Section') =~ m{(?:^|/)(?:tasks|metapackages)$};
+
+ return 1
+ if $self->name =~ /^task-/;
+
+ return 0;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable/Conffiles.pm b/lib/Lintian/Processable/Installable/Conffiles.pm
new file mode 100644
index 0000000..50db7f7
--- /dev/null
+++ b/lib/Lintian/Processable/Installable/Conffiles.pm
@@ -0,0 +1,97 @@
+# -*- perl -*- Lintian::Processable::Installable::Conffiles
+#
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Installable::Conffiles;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Conffiles;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Installable::Conffiles - access to collected control data for conffiles
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Installable::Conffiles provides an interface to control data for conffiles.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item conffiles_item
+
+=cut
+
+has conffiles_item => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return $self->control->resolve_path('conffiles');
+ }
+);
+
+=item declared_conffiles
+
+=cut
+
+has declared_conffiles => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $item = $self->conffiles_item;
+
+ my $conffiles = Lintian::Conffiles->new;
+ $conffiles->parse($item, $self);
+
+ return $conffiles;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable/Control.pm b/lib/Lintian/Processable/Installable/Control.pm
new file mode 100644
index 0000000..b6a72d8
--- /dev/null
+++ b/lib/Lintian/Processable/Installable/Control.pm
@@ -0,0 +1,99 @@
+# -*- perl -*- Lintian::Processable::Installable::Control
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Installable::Control;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(uniq);
+
+use Lintian::Index;
+
+const my $SLASH => q{/};
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Installable::Control - access to collected control file data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Installable::Control provides an interface to control file data.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item control
+
+Returns the index for a binary control file.
+
+=cut
+
+has control => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $index = Lintian::Index->new;
+ my $archive = $self->basename;
+ $index->identifier("$archive (control)");
+ $index->basedir($self->basedir . $SLASH . 'control');
+
+ # control files are not installed relative to the system root
+ # disallow absolute paths and symbolic links
+
+ my @command = (qw(dpkg-deb --ctrl-tarfile), $self->path);
+ my $errors = $index->create_from_piped_tar(\@command);
+
+ my @messages = uniq split(/\n/, $errors);
+ push(@{$index->unpack_messages}, @messages);
+
+ return $index;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable/Installed.pm b/lib/Lintian/Processable/Installable/Installed.pm
new file mode 100644
index 0000000..61444ac
--- /dev/null
+++ b/lib/Lintian/Processable/Installable/Installed.pm
@@ -0,0 +1,103 @@
+# -*- perl -*- Lintian::Processable::Installable::Installed
+#
+# Copyright (C) 2008, 2009 Russ Allbery
+# Copyright (C) 2008 Frank Lichtenheld
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Installable::Installed;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(uniq);
+
+use Lintian::Index;
+
+const my $SLASH => q{/};
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Installable::Installed - access to collected data about the upstream (orig) sources
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Installable::Installed provides an interface to collected data about the upstream (orig) sources.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item installed
+
+Returns a index object representing installed files from a binary package.
+
+=cut
+
+has installed => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $index = Lintian::Index->new;
+ my $archive = $self->basename;
+ $index->identifier("$archive (installed)");
+ $index->basedir($self->basedir . $SLASH . 'unpacked');
+
+ # binary packages are anchored to the system root
+ # allow absolute paths and symbolic links
+ $index->anchored(1);
+
+ my @command = (qw(dpkg-deb --fsys-tarfile), $self->path);
+ my $errors = $index->create_from_piped_tar(\@command);
+
+ my @messages = uniq split(/\n/, $errors);
+ push(@{$index->unpack_messages}, @messages);
+
+ return $index;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable/Overrides.pm b/lib/Lintian/Processable/Installable/Overrides.pm
new file mode 100644
index 0000000..0da551f
--- /dev/null
+++ b/lib/Lintian/Processable/Installable/Overrides.pm
@@ -0,0 +1,131 @@
+# -*- perl -*- Lintian::Processable::Installable::Overrides
+#
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Installable::Overrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use PerlIO::gzip;
+use List::SomeUtils qw(first_value);
+use Unicode::UTF8 qw(valid_utf8 decode_utf8 encode_utf8);
+
+use Moo::Role;
+use namespace::clean;
+
+with 'Lintian::Processable::Overrides';
+
+const my $EMPTY => q{};
+
+=head1 NAME
+
+Lintian::Processable::Installable::Overrides - access to override data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Installable::Overrides provides an interface for overrides.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item override_file
+
+=cut
+
+has override_file => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $unzipped = 'usr/share/lintian/overrides/' . $self->name;
+
+ my @candidates = map { $unzipped . $_ } ($EMPTY, '.gz');
+
+ # pick the first
+ my $override_item= first_value { defined }
+ map { $self->installed->lookup($_) } @candidates;
+
+ return $override_item;
+ }
+);
+
+=item overrides
+
+=cut
+
+has overrides => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return []
+ unless defined $self->override_file;
+
+ my $contents = $EMPTY;
+
+ if ($self->override_file->name =~ m{ [.]gz $}x) {
+
+ my $local_path = $self->override_file->unpacked_path;
+
+ open(my $fd, '<:gzip', $local_path)
+ or die encode_utf8("Cannot open $local_path.");
+
+ local $/ = undef;
+ my $bytes = <$fd>;
+
+ $contents = decode_utf8($bytes)
+ if valid_utf8($bytes);
+
+ close $fd;
+
+ } else {
+ $contents = $self->override_file->decoded_utf8;
+ }
+
+ return $self->parse_overrides($contents);
+ }
+);
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Installable/Relation.pm b/lib/Lintian/Processable/Installable/Relation.pm
new file mode 100644
index 0000000..ac94489
--- /dev/null
+++ b/lib/Lintian/Processable/Installable/Relation.pm
@@ -0,0 +1,154 @@
+# -*- perl -*-
+# Lintian::Processable::Installable::Relation -- interface to binary package data collection
+
+# Copyright (C) 2008, 2009 Russ Allbery
+# Copyright (C) 2008 Frank Lichtenheld
+# Copyright (C) 2012 Kees Cook
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Installable::Relation;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Installable::Relation - Lintian interface to binary package data collection
+
+=head1 SYNOPSIS
+
+ my ($name, $type, $dir) = ('foobar', 'binary', '/path/to/lab-entry');
+ my $collect = Lintian::Processable::Installable::Relation->new($name);
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Installable::Relation provides an interface to package data for binary
+packages. It implements data collection methods specific to binary
+packages.
+
+This module is in its infancy. Most of Lintian still reads all data from
+files in the laboratory whenever that data is needed and generates that
+data via collect scripts. The goal is to eventually access all data about
+binary packages via this module so that the module can cache data where
+appropriate and possibly retire collect scripts in favor of caching that
+data in memory.
+
+Native heuristics are only available in source packages.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item relation (FIELD)
+
+Returns a L<Lintian::Relation> object for the specified FIELD, which should
+be one of the possible relationship fields of a Debian package or one of
+the following special values:
+
+=over 4
+
+=item All
+
+The concatenation of Pre-Depends, Depends, Recommends, and Suggests.
+
+=item Strong
+
+The concatenation of Pre-Depends and Depends.
+
+=item Weak
+
+The concatenation of Recommends and Suggests.
+
+=back
+
+If FIELD isn't present in the package, the returned Lintian::Relation
+object will be empty (always present and satisfies nothing).
+
+=item saved_relations
+
+=cut
+
+has saved_relations => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+my %alias = (
+ all => [qw(Pre-Depends Depends Recommends Suggests)],
+ strong => [qw(Pre-Depends Depends)],
+ weak => [qw(Recommends Suggests)]
+);
+
+my %known = map { $_ => 1 }
+ qw(pre-depends depends recommends suggests enhances breaks
+ conflicts provides replaces);
+
+sub relation {
+ my ($self, $name) = @_;
+
+ my $lowercase = lc $name;
+
+ my $relation = $self->saved_relations->{$lowercase};
+ unless (defined $relation) {
+
+ if (exists $alias{$lowercase}) {
+ $relation
+ = Lintian::Relation->new->logical_and(map { $self->relation($_) }
+ @{ $alias{$lowercase} });
+ } else {
+ croak encode_utf8("unknown relation field $name")
+ unless $known{$lowercase};
+
+ my $value = $self->fields->value($name);
+ $relation = Lintian::Relation->new->load($value);
+ }
+
+ $self->saved_relations->{$lowercase} = $relation;
+ }
+
+ return $relation;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Frank Lichtenheld <djpig@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/IsNonFree.pm b/lib/Lintian/Processable/IsNonFree.pm
new file mode 100644
index 0000000..bd6f246
--- /dev/null
+++ b/lib/Lintian/Processable/IsNonFree.pm
@@ -0,0 +1,109 @@
+# -*- perl -*-
+# Lintian::Processable::IsNonFree -- interface to source package data collection
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::IsNonFree;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::IsNonFree - Lintian interface to source package data collection
+
+=head1 SYNOPSIS
+
+ my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry');
+ my $collect = Lintian::Processable::IsNonFree->new($name);
+ if ($collect->native) {
+ print encode_utf8("Package is native\n");
+ }
+
+=head1 DESCRIPTION
+
+Lintian::Processable::IsNonFree provides an interface to package data for source
+packages. It implements data collection methods specific to source
+packages.
+
+This module is in its infancy. Most of Lintian still reads all data from
+files in the laboratory whenever that data is needed and generates that
+data via collect scripts. The goal is to eventually access all data about
+source packages via this module so that the module can cache data where
+appropriate and possibly retire collect scripts in favor of caching that
+data in memory.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item is_non_free
+
+Returns a truth value if the package appears to be non-free (based on
+the section field; "non-free/*" and "restricted/*")
+
+=cut
+
+has is_non_free => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $section;
+
+ if ($self->type eq 'source') {
+ $section = $self->debian_control->source_fields->value('Section');
+ } else {
+ $section = $self->fields->value('Section');
+ }
+
+ $section ||= 'main';
+
+ return 1
+ if $section
+ =~ m{^(?:non-free|non-free-firmware|restricted|multiverse)/};
+
+ return 0;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/NotJustDocs.pm b/lib/Lintian/Processable/NotJustDocs.pm
new file mode 100644
index 0000000..1e08760
--- /dev/null
+++ b/lib/Lintian/Processable/NotJustDocs.pm
@@ -0,0 +1,112 @@
+# -*- perl -*-
+# Lintian::Processable::NotJustDocs
+
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::NotJustDocs;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::NotJustDocs - Lintian interface to installable package data collection
+
+=head1 SYNOPSIS
+
+ my $processable = Lintian::Processable::Installable->new;
+
+ my $is_empty = $processable->not_just_docs;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::NotJustDocs provides an interface to package data for installation
+packages.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item not_just_docs
+
+Returns a truth value if the package appears to be empty.
+
+=cut
+
+has not_just_docs => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $quoted_name = quotemeta($self->name);
+
+ my $empty = 1;
+ for my $item (@{$self->installed->sorted_list}) {
+
+ # ignore directories
+ next
+ if $item->is_dir;
+
+ # skip /usr/share/doc/$name symlinks.
+ next
+ if $item->name eq 'usr/share/doc/' . $self->name;
+
+ # only look outside /usr/share/doc/$name directory
+ next
+ if $item->name =~ m{^usr/share/doc/$quoted_name};
+
+ # except if it is a lintian override.
+ next
+ if $item->name =~ m{\A
+ # Except for:
+ usr/share/ (?:
+ # lintian overrides
+ lintian/overrides/$quoted_name(?:\.gz)?
+ # reportbug scripts/utilities
+ | bug/$quoted_name(?:/(?:control|presubj|script))?
+ )\Z}xsm;
+
+ return 0;
+ }
+
+ return 1;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Overrides.pm b/lib/Lintian/Processable/Overrides.pm
new file mode 100644
index 0000000..0de05a4
--- /dev/null
+++ b/lib/Lintian/Processable/Overrides.pm
@@ -0,0 +1,219 @@
+# -*- perl -*- Lintian::Processable::Overrides
+#
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Overrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Override;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Overrides - access to override data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Overrides provides an interface to overrides.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item override_errors
+
+=cut
+
+has override_errors => (is => 'rw', default => sub { [] });
+
+=item parse_overrides
+
+=cut
+
+sub parse_overrides {
+ my ($self, $contents) = @_;
+
+ $contents //= $EMPTY;
+
+ my @declared_overrides;
+
+ my $justification = $EMPTY;
+ my $previous = Lintian::Override->new;
+
+ my @lines = split(/\n/, $contents);
+
+ my $position = 1;
+ for my $line (@lines) {
+
+ my $remaining = $line;
+
+ # trim both ends
+ $remaining =~ s/^\s+|\s+$//g;
+
+ if ($remaining eq $EMPTY) {
+ # Throw away comments, as they are not attached to a tag
+ # also throw away the option of "carrying over" the last
+ # comment
+ $justification = $EMPTY;
+ $previous = Lintian::Override->new;
+ next;
+ }
+
+ if ($remaining =~ s{^ [#] \s* }{}x) {
+
+ if (length $remaining) {
+
+ $justification .= $SPACE
+ if length $justification;
+
+ $justification .= $remaining;
+ }
+
+ next;
+ }
+
+ # reduce white space
+ $remaining =~ s/\s+/ /g;
+
+ # [[pkg-name] [arch-list] [pkg-type]:] <tag> [context]
+ my $require_colon = 0;
+ my @architectures;
+
+ # strip package name, if present; require name
+ # parsing overrides is ambiguous (see #699628)
+ my $package = $self->name;
+ if ($remaining =~ s/^\Q$package\E(?=\s|:)//) {
+
+ # both spaces or colon were unmatched lookhead
+ $remaining =~ s/^\s+//;
+ $require_colon = 1;
+ }
+
+ # remove architecture list
+ if ($remaining =~ s{^ \[ ([^\]]*) \] (?=\s|:)}{}x) {
+
+ my $list = $1;
+
+ @architectures = split($SPACE, $list);
+
+ # both spaces or colon were unmatched lookhead
+ $remaining =~ s/^\s+//;
+ $require_colon = 1;
+ }
+
+ # remove package type
+ my $type = $self->type;
+ if ($remaining =~ s/^\Q$type\E(?=\s|:)//) {
+
+ # both spaces or colon were unmatched lookhead
+ $remaining =~ s/^\s+//;
+ $require_colon = 1;
+ }
+
+ my $pointer = $self->override_file->pointer($position);
+
+ # require and remove colon when any package details are present
+ if ($require_colon && $remaining !~ s/^\s*:\s*//) {
+
+ my %error;
+ $error{message} = 'Expected a colon';
+ $error{pointer} = $pointer;
+ push(@{$self->override_errors}, \%error);
+
+ next;
+ }
+
+ my $hint_like = $remaining;
+
+ my ($tag_name, $pattern) = split($SPACE, $hint_like, 2);
+
+ if (!length $tag_name) {
+
+ my %error;
+ $error{message} = "Cannot parse line: $line";
+ $error{pointer} = $pointer;
+ push(@{$self->override_errors}, \%error);
+
+ next;
+ }
+
+ $pattern //= $EMPTY;
+
+ # There are no new comments, no "empty line" in between and
+ # this tag is the same as the last, so we "carry over" the
+ # comment from the previous override (if any).
+ $justification = $previous->justification
+ if !length $justification
+ && $tag_name eq $previous->tag_name;
+
+ my $current = Lintian::Override->new;
+
+ $current->tag_name($tag_name);
+ $current->architectures(\@architectures);
+ $current->pattern($pattern);
+ $current->position($position);
+
+ # combine successive white space
+ $justification =~ s{ \s+ }{ }gx;
+
+ $current->justification($justification);
+ $justification = $EMPTY;
+
+ push(@declared_overrides, $current);
+
+ $previous = $current;
+
+ } continue {
+ $position++;
+ }
+
+ return \@declared_overrides;
+}
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source.pm b/lib/Lintian/Processable/Source.pm
new file mode 100644
index 0000000..e4dc001
--- /dev/null
+++ b/lib/Lintian/Processable/Source.pm
@@ -0,0 +1,142 @@
+# Copyright (C) 2019-2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Processable::Source;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use File::Spec;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+with
+ 'Lintian::Processable',
+ 'Lintian::Processable::Diffstat',
+ 'Lintian::Processable::Changelog::Version',
+ 'Lintian::Processable::Debian::Control',
+ 'Lintian::Processable::Fields::Files',
+ 'Lintian::Processable::IsNonFree',
+ 'Lintian::Processable::Source::Changelog',
+ 'Lintian::Processable::Source::Components',
+ 'Lintian::Processable::Source::Format',
+ 'Lintian::Processable::Source::Orig',
+ 'Lintian::Processable::Source::Overrides',
+ 'Lintian::Processable::Source::Patched',
+ 'Lintian::Processable::Source::Relation',
+ 'Lintian::Processable::Source::Repacked';
+
+=for Pod::Coverage BUILDARGS
+
+=head1 NAME
+
+Lintian::Processable::Source -- A dsc source package Lintian can process
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable::Source;
+
+ my $processable = Lintian::Processable::Source->new;
+ $processable->init_from_file('path');
+
+=head1 DESCRIPTION
+
+This class represents a 'dsc' file that Lintian can process. Objects
+of this kind are often part of a L<Lintian::Group>, which
+represents all the files in a changes or buildinfo file.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item init_from_file (PATH)
+
+Initializes a new object from PATH.
+
+=cut
+
+sub init_from_file {
+ my ($self, $file) = @_;
+
+ croak encode_utf8("File $file does not exist")
+ unless -e $file;
+
+ $self->path($file);
+ $self->type('source');
+
+ my $primary = Lintian::Deb822->new;
+ my @sections = $primary->read_file($self->path)
+ or croak encode_utf8($self->path . ' is not valid dsc file');
+
+ $self->fields($sections[0]);
+
+ my $name = $self->fields->value('Source');
+ my $version = $self->fields->value('Version');
+ my $architecture = 'source';
+
+ # it is its own source package
+ my $source_name = $name;
+ my $source_version = $version;
+
+ croak encode_utf8($self->path . ' is missing Source field')
+ unless length $name;
+
+ $self->name($name);
+ $self->version($version);
+ $self->architecture($architecture);
+ $self->source_name($source_name);
+ $self->source_version($source_version);
+
+ # make sure none of these fields can cause traversal
+ $self->tainted(1)
+ if $self->name ne $name
+ || $self->version ne $version
+ || $self->architecture ne $architecture
+ || $self->source_name ne $source_name
+ || $self->source_version ne $source_version;
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Changelog.pm b/lib/Lintian/Processable/Source/Changelog.pm
new file mode 100644
index 0000000..a781057
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Changelog.pm
@@ -0,0 +1,109 @@
+# -*- perl -*- Lintian::Processable::Source::Changelog -- access to collected changelog data
+#
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Changelog;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Source::Changelog - access to collected changelog data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Changelog provides an interface to changelog data.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item changelog_item
+
+=cut
+
+has changelog_item => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $item = $self->patched->resolve_path('debian/changelog');
+
+ return $item;
+ }
+);
+
+=item changelog
+
+Returns the changelog of the source package as a Parse::DebianChangelog
+object, or an empty object if the changelog cannot be resolved safely.
+
+=cut
+
+has changelog => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $changelog = Lintian::Changelog->new;
+
+ my $item = $self->changelog_item;
+
+ # return empty changelog
+ return $changelog
+ unless defined $item && $item->is_open_ok;
+
+ return $changelog
+ unless $item->is_valid_utf8;
+
+ $changelog->parse($item->decoded_utf8);
+
+ return $changelog;
+ }
+);
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Components.pm b/lib/Lintian/Processable/Source/Components.pm
new file mode 100644
index 0000000..1541abe
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Components.pm
@@ -0,0 +1,126 @@
+# -*- perl -*-
+# Lintian::Processable::Source::Components -- interface to orig tag components
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Components;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo::Role;
+use namespace::clean;
+
+const my $EMPTY => q{};
+
+=head1 NAME
+
+Lintian::Processable::Source::Components - interface to orig tar components
+
+=head1 SYNOPSIS
+
+ use Moo;
+
+ with 'Lintian::Processable::Source::Components';
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Components provides an interface to data for
+upstream source components. Most sources only use one tarball.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item components
+
+Returns a reference to a hash containing information about source components
+listed in the .dsc file. The key is the filename, and the value is the name
+of the component.
+
+=cut
+
+has components => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # determine source and version; handle missing fields
+ my $name = $self->fields->value('Source');
+ my $version = $self->fields->value('Version');
+ my $architecture = 'source';
+
+ # it is its own source package
+ my $source = $name;
+ my $source_version = $version;
+
+ # version handling based on Dpkg::Version::parseversion.
+ my $noepoch = $source_version;
+ if ($noepoch =~ /:/) {
+ $noepoch =~ s/^(?:\d+):(.+)/$1/
+ or die encode_utf8("Bad version number '$noepoch'");
+ }
+
+ my $baserev = $source . '_' . $noepoch;
+
+ # strip debian revision
+ $noepoch =~ s/(.+)-(?:.*)$/$1/;
+ my $base = $source . '_' . $noepoch;
+
+ my $files = $self->files;
+
+ my %components;
+ for my $name (keys %{$files}) {
+
+ # Look for $pkg_$version.orig(-$comp)?.tar.$ext (non-native)
+ # or $pkg_$version.tar.$ext (native)
+ # - This deliberately does not look for the debian packaging
+ # even when this would be a tarball.
+ if ($name
+ =~ /^(?:\Q$base\E\.orig(?:-(.*))?|\Q$baserev\E)\.tar\.(?:gz|bz2|lzma|xz)$/
+ ) {
+ $components{$name} = $1 // $EMPTY;
+ }
+ }
+
+ return \%components;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Adam D. Barratt <adsb@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1), L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Format.pm b/lib/Lintian/Processable/Source/Format.pm
new file mode 100644
index 0000000..551f93e
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Format.pm
@@ -0,0 +1,136 @@
+# -*- perl -*-
+# Lintian::Processable::Source::Format -- interface to source package data collection
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Format;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Path::Tiny;
+
+use Moo::Role;
+use namespace::clean;
+
+const my $UNDERSCORE => q{_};
+
+=head1 NAME
+
+Lintian::Processable::Source::Format - Lintian interface to source format
+
+=head1 SYNOPSIS
+
+ my $collect = Lintian::Processable::Source::Format->new;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Format provides an interface to source format
+information.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item source_format
+
+=cut
+
+has source_format => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $format = $self->fields->value('Format') || '1.0';
+
+ return $format;
+ }
+);
+
+=item native
+
+Returns true if the source package is native and false otherwise.
+This is generally determined from the source format, though in the 1.0
+case the nativeness is determined by looking for the diff.gz (using
+the name of the source package and its version).
+
+If the source format is 1.0 and the version number is absent, this
+will return false (as native packages are a lot rarer than non-native
+ones).
+
+Note if the source format is missing, it is assumed to be a 1.0
+package.
+
+=cut
+
+has native => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $format = $self->source_format;
+
+ return 0
+ if $format =~ /^\s*2\.0\s*$/;
+
+ return 0
+ if $format =~ /^\s*3\.0\s+\(quilt|git\)\s*$/;
+
+ return 1
+ if $format =~ /^\s*3\.0\s+\(native\)\s*$/;
+
+ my $version = $self->fields->value('Version');
+ return 0
+ unless length $version;
+
+ # strip epoch
+ $version =~ s/^\d+://;
+
+ my $diffname = $self->name . $UNDERSCORE . "$version.diff.gz";
+
+ return 0
+ if exists $self->files->{$diffname};
+
+ return 1;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1), Lintian::Relation(3)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Orig.pm b/lib/Lintian/Processable/Source/Orig.pm
new file mode 100644
index 0000000..dd263f5
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Orig.pm
@@ -0,0 +1,200 @@
+# -*- perl -*- Lintian::Processable::Source::Orig
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Orig;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(uniq);
+use List::UtilsBy qw(sort_by);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Index;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Source::Orig - access to collected data about the upstream (orig) sources
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Orig provides an interface to collected data about the upstream (orig) sources.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item orig
+
+Returns the index for orig.tar.gz.
+
+=cut
+
+my %DECOMPRESS_COMMAND = (
+ 'gz' => 'gzip --decompress --stdout',
+ 'bz2' => 'bzip2 --decompress --stdout',
+ 'xz' => 'xz --decompress --stdout',
+);
+
+has orig => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $index = Lintian::Index->new;
+ my $archive = $self->basename;
+ $index->identifier("$archive (orig)");
+ $index->basedir($self->basedir . $SLASH . 'orig');
+
+ return $index
+ if $self->native;
+
+ # source packages can be unpacked anywhere; no anchored roots
+ $index->anchored(0);
+
+ my %components = %{$self->components};
+
+ # keep sort order; root is missing below otherwise
+ my @tarballs = sort_by { $components{$_} } keys %components;
+
+ for my $tarball (@tarballs) {
+
+ my $component = $components{$tarball};
+
+ # so far, all archives with components had an extra level
+ my $component_dir = $index->basedir;
+ $component_dir .= $SLASH . $component
+ if length $component;
+
+ my $subindex = Lintian::Index->new;
+ $subindex->basedir($component_dir);
+
+ # source packages can be unpacked anywhere; no anchored roots
+ $index->anchored(0);
+
+ my ($extension) = ($tarball =~ /\.([^.]+)$/);
+ die encode_utf8("Source component $tarball has no file exension\n")
+ unless length $extension;
+
+ my $decompress = $DECOMPRESS_COMMAND{lc $extension};
+ die encode_utf8("Don't know how to decompress $tarball")
+ unless $decompress;
+
+ my @command
+ = (split($SPACE, $decompress),
+ $self->basedir . $SLASH . $tarball);
+
+ my $errors = $subindex->create_from_piped_tar(\@command);
+
+ push(@{$index->unpack_messages}, "$tarball . $_")
+ for grep { !/^tar: Ignoring / } uniq split(/\n/, $errors);
+
+ # treat hard links like regular files
+ my @hardlinks = grep { $_->is_hardlink } @{$subindex->sorted_list};
+ for my $item (@hardlinks) {
+
+ my $target = $subindex->lookup($item->link);
+
+ $item->unpacked_path($target->unpacked_path);
+ $item->size($target->size);
+ $item->link($EMPTY);
+
+ # turn into a regular file
+ my $perm = $item->perm;
+ $perm =~ s/^-/h/;
+ $item->perm($perm);
+
+ $item->path_info(
+ ($item->path_info & ~Lintian::Index::Item::TYPE_HARDLINK)
+ | Lintian::Index::Item::TYPE_FILE);
+ }
+
+ my @prefixes = @{$subindex->sorted_list};
+
+ # keep top level prefixes; no trailing slashes
+ s{^([^/]+).*$}{$1}s for @prefixes;
+
+ # squash identical values; ignore root entry ('')
+ my @unique = grep { length } uniq @prefixes;
+
+ # check for single common value
+ if (@unique == 1) {
+
+ # no trailing slash for directories
+ my $common = $unique[0];
+
+ # proceed if no file with that name (lacks slash)
+ my $conflict = $subindex->lookup($common);
+ unless (defined $conflict) {
+
+ if ($common ne $component || length $component) {
+
+ # shortens paths; keeps same base directory
+ my $sub_errors = $subindex->drop_common_prefix;
+
+ push(@{$index->unpack_errors}, "$tarball . $_")
+ for uniq split(/\n/, $sub_errors);
+ }
+ }
+ }
+
+ # lowers base directory to match index being merged into
+ $subindex->capture_common_prefix
+ if length $component;
+
+ $index->merge_in($subindex);
+ }
+
+ return $index;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Overrides.pm b/lib/Lintian/Processable/Source/Overrides.pm
new file mode 100644
index 0000000..d4c446f
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Overrides.pm
@@ -0,0 +1,109 @@
+# -*- perl -*- Lintian::Processable::Source::Overrides
+#
+# Copyright (C) 2019-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Overrides;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use List::SomeUtils qw(first_value);
+
+use Moo::Role;
+use namespace::clean;
+
+with 'Lintian::Processable::Overrides';
+
+=head1 NAME
+
+Lintian::Processable::Source::Overrides - access to override data
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Overrides provides an interface to overrides.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item override_file
+
+=cut
+
+has override_file => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ # prefer source/lintian-overrides to source.lintian-overrides
+ my @candidates = (
+ 'debian/source/lintian-overrides',
+ 'debian/source.lintian-overrides'
+ );
+
+ # pick the first
+ my $override_item= first_value { defined }
+ map { $self->patched->lookup($_) } @candidates;
+
+ return $override_item;
+ }
+);
+
+=item overrides
+
+=cut
+
+has overrides => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ return []
+ unless defined $self->override_file;
+
+ my $contents = $self->override_file->decoded_utf8;
+
+ return $self->parse_overrides($contents);
+ }
+);
+
+1;
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Patched.pm b/lib/Lintian/Processable/Source/Patched.pm
new file mode 100644
index 0000000..229311f
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Patched.pm
@@ -0,0 +1,161 @@
+# -*- perl -*- Lintian::Processable::Source::Patched
+#
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Patched;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Cwd;
+use List::SomeUtils qw(uniq);
+use IPC::Run3;
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+use Lintian::Index;
+use Lintian::Index::Item;
+
+const my $COLON => q{:};
+const my $SLASH => q{/};
+const my $NEWLINE => qq{\n};
+
+const my $NO_UMASK => 0000;
+const my $WAIT_STATUS_SHIFT => 8;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Source::Patched - access to sources with Debian patches applied
+
+=head1 SYNOPSIS
+
+ use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Patched provides an interface to collected data about patched sources.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item patched
+
+Returns a index object representing a patched source tree.
+
+=cut
+
+has patched => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $index = Lintian::Index->new;
+ my $archive = $self->basename;
+ $index->identifier("$archive (patched)");
+ $index->basedir($self->basedir . $SLASH . 'unpacked');
+
+ # source packages can be unpacked anywhere; no anchored roots
+ $index->anchored(0);
+
+ path($index->basedir)->remove_tree
+ if -d $index->basedir;
+
+ print encode_utf8("N: Using dpkg-source to unpack\n")
+ if $ENV{'LINTIAN_DEBUG'};
+
+ my $saved_umask = umask;
+ umask $NO_UMASK;
+
+ my @unpack_command= (
+ qw(dpkg-source -q --no-check --extract),
+ $self->path, $index->basedir
+ );
+
+ # ignore STDOUT; older versions are not completely quiet with -q
+ my $unpack_errors;
+
+ run3(\@unpack_command, \undef, \undef, \$unpack_errors);
+ my $status = ($? >> $WAIT_STATUS_SHIFT);
+
+ $unpack_errors = decode_utf8($unpack_errors)
+ if length $unpack_errors;
+
+ if ($status) {
+ my $message = "Non-zero status $status from @unpack_command";
+ $message .= $COLON . $NEWLINE . $unpack_errors
+ if length $unpack_errors;
+
+ die encode_utf8($message);
+ }
+
+ umask $saved_umask;
+
+ my $index_errors = $index->create_from_basedir;
+
+ my $savedir = getcwd;
+ chdir($index->basedir)
+ or die encode_utf8('Cannot change to directory ' . $index->basedir);
+
+ # fix permissions
+ my @permissions_command
+ = ('chmod', '-R', 'u+rwX,o+rX,o-w', $index->basedir);
+ my $permissions_errors;
+
+ run3(\@permissions_command, \undef, \undef, \$permissions_errors);
+
+ $permissions_errors = decode_utf8($permissions_errors)
+ if length $permissions_errors;
+
+ chdir($savedir)
+ or die encode_utf8("Cannot change to directory $savedir");
+
+ my @messages = grep { !/^tar: Ignoring / }
+ split(/\n/, $unpack_errors . $index_errors . $permissions_errors);
+ push(@{$index->unpack_messages}, @messages);
+
+ return $index;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Relation.pm b/lib/Lintian/Processable/Source/Relation.pm
new file mode 100644
index 0000000..e66297c
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Relation.pm
@@ -0,0 +1,267 @@
+# -*- perl -*-
+# Lintian::Processable::Source::Relation -- interface to source package data collection
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Relation;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Source::Relation - Lintian interface to source package data collection
+
+=head1 SYNOPSIS
+
+ my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry');
+ my $collect = Lintian::Processable::Source::Relation->new($name);
+ if ($collect->native) {
+ print encode_utf8("Package is native\n");
+ }
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Relation provides an interface to package data for source
+packages. It implements data collection methods specific to source
+packages.
+
+This module is in its infancy. Most of Lintian still reads all data from
+files in the laboratory whenever that data is needed and generates that
+data via collect scripts. The goal is to eventually access all data about
+source packages via this module so that the module can cache data where
+appropriate and possibly retire collect scripts in favor of caching that
+data in memory.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item binary_relation (PACKAGE, FIELD)
+
+Returns a L<Lintian::Relation> object for the specified FIELD in the
+binary package PACKAGE in the F<debian/control> file. FIELD should be
+one of the possible relationship fields of a Debian package or one of
+the following special values:
+
+=over 4
+
+=item All
+
+The concatenation of Pre-Depends, Depends, Recommends, and Suggests.
+
+=item Strong
+
+The concatenation of Pre-Depends and Depends.
+
+=item Weak
+
+The concatenation of Recommends and Suggests.
+
+=back
+
+If FIELD isn't present in the package, the returned Lintian::Relation
+object will be empty (present but satisfies nothing).
+
+Any substvars in F<debian/control> will be represented in the returned
+relation as packages named after the substvar.
+
+=item saved_binary_relations
+
+=cut
+
+has saved_binary_relations => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+my %alias = (
+ all => [qw(Pre-Depends Depends Recommends Suggests)],
+ strong => [qw(Pre-Depends Depends)],
+ weak => [qw(Recommends Suggests)]
+);
+
+my %known = map { $_ => 1 }
+ qw(pre-depends depends recommends suggests enhances breaks
+ conflicts provides replaces);
+
+sub binary_relation {
+ my ($self, $package, $name) = @_;
+
+ return undef
+ unless length $name;
+
+ my $lowercase = lc $name;
+
+ return undef
+ unless length $package;
+
+ my $relation = $self->saved_binary_relations->{$package}{$lowercase};
+ unless (defined $relation) {
+
+ if (length $alias{$lowercase}) {
+ $relation
+ = Lintian::Relation->new->logical_and(
+ map { $self->binary_relation($package, $_) }
+ @{ $alias{$lowercase} });
+
+ } else {
+ croak encode_utf8("unknown relation field $name")
+ unless $known{$lowercase};
+
+ my $value
+ = $self->debian_control->installable_fields($package)
+ ->value($name);
+ $relation = Lintian::Relation->new->load($value);
+ }
+
+ $self->saved_binary_relations->{$package}{$lowercase} = $relation;
+ }
+
+ return $relation;
+}
+
+=item relation (FIELD)
+
+Returns a L<Lintian::Relation> object for the given build relationship
+field FIELD. In addition to the normal build relationship fields, the
+following special field names are supported:
+
+=over 4
+
+=item Build-Depends-All
+
+The concatenation of Build-Depends, Build-Depends-Arch and
+Build-Depends-Indep.
+
+=item Build-Conflicts-All
+
+The concatenation of Build-Conflicts, Build-Conflicts-Arch and
+Build-Conflicts-Indep.
+
+=back
+
+If FIELD isn't present in the package, the returned Lintian::Relation
+object will be empty (present but satisfies nothing).
+
+=item saved_relation
+
+=cut
+
+has saved_relations => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+sub relation {
+ my ($self, $name) = @_;
+
+ return undef
+ unless length $name;
+
+ my $lowercase = lc $name;
+
+ my $relation = $self->saved_relations->{$lowercase};
+ unless (defined $relation) {
+
+ if ($name =~ /^Build-(Depends|Conflicts)-All$/i) {
+ my $type = $1;
+ my @fields
+ = ("Build-$type", "Build-$type-Indep", "Build-$type-Arch");
+ $relation
+ = Lintian::Relation->new->logical_and(map { $self->relation($_) }
+ @fields);
+
+ } elsif ($name =~ /^Build-(Depends|Conflicts)(?:-(?:Arch|Indep))?$/i){
+ my $value = $self->fields->value($name);
+ $relation = Lintian::Relation->new->load($value);
+
+ } else {
+ croak encode_utf8("unknown relation field $name");
+ }
+
+ $self->saved_relations->{$lowercase} = $relation;
+ }
+
+ return $relation;
+}
+
+=item relation_norestriction (FIELD)
+
+The same as L</relation (FIELD)>, but ignores architecture
+restrictions and build profile restrictions in the FIELD field.
+
+=item saved_relations_norestriction
+
+=cut
+
+has saved_relations_norestriction => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+sub relation_norestriction {
+ my ($self, $name) = @_;
+
+ return undef
+ unless length $name;
+
+ my $lowercase = lc $name;
+
+ my $relation = $self->saved_relations_norestriction->{$lowercase};
+ unless (defined $relation) {
+
+ $relation = $self->relation($name)->restriction_less;
+ $self->saved_relations_norestriction->{$lowercase} = $relation;
+ }
+
+ return $relation;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Processable/Source/Repacked.pm b/lib/Lintian/Processable/Source/Repacked.pm
new file mode 100644
index 0000000..4cf057b
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Repacked.pm
@@ -0,0 +1,99 @@
+# -*- perl -*-
+# Lintian::Processable::Source::Repacked -- interface to source package data collection
+
+# Copyright (C) 2008 Russ Allbery
+# Copyright (C) 2009 Raphael Geissert
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Repacked;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Lintian::Util qw($PKGREPACK_REGEX);
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Source::Repacked - Lintian interface to source package data collection
+
+=head1 SYNOPSIS
+
+ my ($name, $type, $dir) = ('foobar', 'source', '/path/to/lab-entry');
+ my $collect = Lintian::Processable::Source::Repacked->new($name);
+ if ($collect->native) {
+ print encode_utf8("Package is native\n");
+ }
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Repacked provides an interface to package data for source
+packages. It implements data collection methods specific to source
+packages.
+
+This module is in its infancy. Most of Lintian still reads all data from
+files in the laboratory whenever that data is needed and generates that
+data via collect scripts. The goal is to eventually access all data about
+source packages via this module so that the module can cache data where
+appropriate and possibly retire collect scripts in favor of caching that
+data in memory.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item repacked
+
+Returns true if the source package has been "repacked" and false otherwise.
+This is determined from the version name containing "dfsg" or similar.
+
+=cut
+
+has repacked => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $upstream = $self->changelog_version->upstream;
+
+ return $upstream =~ $PKGREPACK_REGEX;
+ }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+Amended by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Profile.pm b/lib/Lintian/Profile.pm
new file mode 100644
index 0000000..643e21f
--- /dev/null
+++ b/lib/Lintian/Profile.pm
@@ -0,0 +1,941 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Profile;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(carp croak);
+use Const::Fast;
+use Cwd qw(realpath);
+use File::BaseDir qw(config_home config_files data_home);
+use File::Find::Rule;
+use List::Compare;
+use List::SomeUtils qw(any none uniq first_value);
+use Path::Tiny;
+use POSIX qw(ENOENT);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Dpkg::Vendor qw(get_current_vendor get_vendor_info);
+
+use Lintian::Data;
+use Lintian::Deb822;
+use Lintian::Tag;
+use Lintian::Util qw(match_glob);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $HYPHEN => q{-};
+const my $EQUAL => q{=};
+
+const my $FIELD_SEPARATOR => qr/ \s+ | \s* , \s* /sx;
+
+const my @VALID_HEADER_FIELDS => qw(
+ Profile
+ Extends
+ Enable-Tags-From-Check
+ Disable-Tags-From-Check
+ Enable-Tags
+ Disable-Tags
+);
+
+const my @VALID_BODY_FIELDS => qw(
+ Tags
+ Overridable
+);
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Profile - Profile parser for Lintian
+
+=head1 SYNOPSIS
+
+ my $profile = Lintian::Profile->new ('debian');
+
+=head1 DESCRIPTION
+
+Lintian::Profile handles finding, parsing and implementation of
+Lintian Profiles as well as loading the relevant Lintian checks.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item $prof->known_aliases()
+
+Returns a hash with old names that have new names.
+
+=item $prof->profile_list
+
+Returns a list ref of the (normalized) names of the profile and its
+parents. The first element of the list is the name of the profile
+itself, the second is its parent and so on.
+
+Note: This list is a reference. The contents should not be modified.
+
+=item our_vendor
+
+=item $prof->name
+
+Returns the name of the profile, which may differ from the name used
+to create this instance of the profile (e.g. due to symlinks).
+
+=cut
+
+has known_aliases => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has check_module_by_name => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has check_path_by_name => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has tag_names_for_check => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has display_level_lookup => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub {
+ {
+ classification => 0,
+ pedantic => 0,
+ info => 0,
+ warning => 1,
+ error => 1,
+ }
+ }
+);
+
+has enabled_checks_by_name => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has enabled_tags_by_name => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has files => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has known_tags_by_name => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has name => (
+ is => 'rw',
+ coerce => sub { my ($string) = @_; return $string // $EMPTY;},
+ default => $EMPTY
+);
+
+has durable_tags_by_name => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has data => (
+ is => 'rw',
+ lazy => 1,
+ default => sub {
+ my ($self) = @_;
+
+ my $data = Lintian::Data->new;
+
+ my @DATA_PATHS = $self->search_space('data');
+ $data->data_paths(\@DATA_PATHS);
+ $data->vendor($self->our_vendor);
+
+ return $data;
+ }
+);
+
+has parent_map => (
+ is => 'rw',
+ coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
+ default => sub { {} }
+);
+
+has profile_list => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+has our_vendor => (is => 'rw');
+
+has include_dirs => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+# Temporary until aptdaemon (etc.) has been upgraded to handle
+# Lintian loading code from user dirs.
+# LP: #1162947
+has safe_include_dirs => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+has known_vendors => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub {
+
+ my $vendor = Dpkg::Vendor::get_current_vendor();
+ croak encode_utf8('Could not determine the current vendor')
+ unless $vendor;
+
+ my @vendors;
+ push(@vendors, lc $vendor);
+
+ while ($vendor) {
+ my $info = Dpkg::Vendor::get_vendor_info($vendor);
+ # Cannot happen atm, but in case Dpkg::Vendor changes its internals
+ # or our code changes
+ croak encode_utf8("Could not look up the parent vendor of $vendor")
+ unless $info;
+
+ $vendor = $info->{'Parent'};
+ push(@vendors, lc $vendor)
+ if $vendor;
+ }
+
+ return \@vendors;
+ }
+);
+
+has user_dirs => (
+ is => 'ro',
+ lazy => 1,
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub {
+ my ($self) = @_;
+
+ my @user_data;
+
+ # XDG user data
+ push(@user_data, data_home('lintian'));
+
+ # legacy per-user data
+ push(@user_data, "$ENV{HOME}/.lintian")
+ if length $ENV{HOME};
+
+ # system wide user data
+ push(@user_data, '/etc/lintian');
+
+ const my @IMMUTABLE => grep { length && -e } @user_data;
+
+ return \@IMMUTABLE;
+ }
+);
+
+=item load ([$profname[, $ipath[, $extra]]])
+
+Loads a new profile. $profname is the name of the profile and $ipath
+is a list reference containing the path to one (or more) Lintian
+"roots".
+
+If $profname is C<undef>, the default vendor will be loaded based on
+Dpkg::Vendor::get_current_vendor.
+
+If $ipath is not given, a default one will be used.
+
+=cut
+
+sub load {
+ my ($self, $profile_name, $requested_dirs, $allow_user_dirs) = @_;
+
+ $requested_dirs //= [];
+
+ my @distribution_dirs = ($ENV{LINTIAN_BASE} // '/usr/share/lintian');
+
+ const my @SAFE_INCLUDE_DIRS => (@{$requested_dirs}, @distribution_dirs);
+ $self->safe_include_dirs(\@SAFE_INCLUDE_DIRS);
+
+ my @all_dirs;
+
+ push(@all_dirs, @{$self->user_dirs})
+ if $allow_user_dirs && @{$self->user_dirs};
+
+ push(@all_dirs, @{$self->safe_include_dirs});
+
+ const my @ALL_INCLUDE_DIRS => @all_dirs;
+ $self->include_dirs(\@ALL_INCLUDE_DIRS);
+
+ for
+ my $tagdir (map { ($_ // q{.}) . '/tags' } @{$self->safe_include_dirs}) {
+
+ next
+ unless -d $tagdir;
+
+ my @tagpaths
+ = File::Find::Rule->file->name(qw(*.tag *.desc))->in($tagdir);
+ for my $tagpath (@tagpaths) {
+
+ my $tag = Lintian::Tag->new;
+ $tag->load($self, $tagpath);
+
+ die encode_utf8("Tag in $tagpath is not associated with a check")
+ unless length $tag->check;
+
+ next
+ if exists $self->known_tags_by_name->{$tag->name};
+
+ $self->known_tags_by_name->{$tag->name} = $tag;
+ $self->tag_names_for_check->{$tag->check} //= [];
+ push(@{$self->tag_names_for_check->{$tag->check}},$tag->name);
+
+ # record known aliases
+ my @taken
+ = grep { exists $self->known_aliases->{$_} }
+ @{$tag->renamed_from};
+
+ die encode_utf8('These aliases of the tag '
+ . $tag->name
+ . ' are taken already: '
+ . join($SPACE, @taken))
+ if @taken;
+
+ for my $old_name (@{$tag->renamed_from}) {
+
+ if (exists $self->known_aliases->{$old_name}) {
+
+ my $taken = $self->known_aliases->{$old_name};
+ my $tag_name = $tag->name;
+ warn encode_utf8(
+"Alias $old_name for $tag_name ignored; already taken by $taken"
+ );
+
+ } else {
+ $self->known_aliases->{$old_name} = $tag->name;
+ }
+ }
+ }
+ }
+
+ my @check_bases
+ = map {(($_ // q{.}).'/lib/Lintian/Check', ($_ // q{.}).'/checks')}
+ @{$self->safe_include_dirs};
+ for my $check_base (@check_bases) {
+
+ next
+ unless -d $check_base;
+
+ my @check_paths= File::Find::Rule->file->name('*.pm')->in($check_base);
+
+ for my $absolute (@check_paths) {
+
+ my $relative = path($absolute)->relative($check_base)->stringify;
+ $relative =~ s{\.pm$}{};
+
+ my $name = $relative;
+ $name =~ s{([[:upper:]])}{-\L$1}g;
+ $name =~ s{^-}{};
+ $name =~ s{/-}{/}g;
+
+ # ignore duplicates
+ next
+ if exists $self->check_module_by_name->{$name};
+
+ $self->check_path_by_name->{$name} = $absolute;
+
+ my $module = $relative;
+
+ # replace slashes with double colons
+ $module =~ s{/}{::}g;
+
+ $self->check_module_by_name->{$name} = "Lintian::Check::$module";
+ }
+ }
+
+ $self->read_profile($profile_name);
+
+ return;
+}
+
+=item $prof->known_tags
+
+=cut
+
+sub known_tags {
+ my ($self) = @_;
+
+ return keys %{ $self->known_tags_by_name };
+}
+
+=item $prof->enabled_tags
+
+=cut
+
+sub enabled_tags {
+ my ($self) = @_;
+
+ return keys %{ $self->enabled_tags_by_name };
+}
+
+=item $prof->get_tag ($name)
+
+Returns the Lintian::Tag for $tag if known.
+Otherwise it returns undef.
+
+=cut
+
+sub get_tag {
+ my ($self, $maybe_historical) = @_;
+
+ my $name = $self->get_current_name($maybe_historical);
+ return undef
+ unless length $name;
+
+ return $self->known_tags_by_name->{$name}
+ if exists $self->known_tags_by_name->{$name};
+
+ return undef;
+}
+
+=item get_current_name
+
+=cut
+
+sub get_current_name {
+ my ($self, $tag_name) = @_;
+
+ return $self->known_aliases->{$tag_name}
+ if exists $self->known_aliases->{$tag_name};
+
+ return $tag_name
+ if exists $self->known_tags_by_name->{$tag_name};
+
+ return $EMPTY;
+}
+
+=item set_durable ($tag)
+
+=cut
+
+sub set_durable {
+ my ($self, $maybe_historical, $status) = @_;
+
+ my $tag = $self->get_tag($maybe_historical);
+ croak encode_utf8("Unknown tag $maybe_historical.")
+ unless defined $tag;
+
+ $self->durable_tags_by_name->{$tag->name} = 1
+ if $status;
+
+ # settings from tag govern
+ delete $self->durable_tags_by_name->{$tag->name}
+ if !$status && !$tag->show_always;
+
+ return;
+}
+
+=item $prof->is_durable ($tag)
+
+Returns a false value if the tag has been marked as
+"non-overridable". Otherwise it returns a truth value.
+
+=cut
+
+sub is_durable {
+ my ($self, $maybe_historical) = @_;
+
+ my $tag = $self->get_tag($maybe_historical);
+ croak encode_utf8("Unknown tag $maybe_historical.")
+ unless defined $tag;
+
+ return 1
+ if $tag->show_always
+ || exists $self->durable_tags_by_name->{$tag->name};
+
+ return 0;
+}
+
+=item $prof->known_checks
+
+=cut
+
+sub known_checks {
+ my ($self) = @_;
+
+ return keys %{ $self->check_module_by_name };
+}
+
+=item $prof->enabled_checks
+
+=cut
+
+sub enabled_checks {
+ my ($self) = @_;
+
+ return keys %{ $self->enabled_checks_by_name };
+}
+
+=item $prof->enable_tag ($name)
+
+Enables a tag.
+
+=cut
+
+sub enable_tag {
+ my ($self, $maybe_historical) = @_;
+
+ my $tag = $self->get_tag($maybe_historical);
+ croak encode_utf8("Unknown tag $maybe_historical.")
+ unless defined $tag;
+
+ $self->enabled_checks_by_name->{$tag->check}++
+ unless exists $self->enabled_tags_by_name->{$tag->name};
+
+ $self->enabled_tags_by_name->{$tag->name} = 1;
+
+ return;
+}
+
+=item $prof->disable_tag ($name)
+
+Disable a tag.
+
+=cut
+
+sub disable_tag {
+ my ($self, $maybe_historical) = @_;
+
+ my $tag = $self->get_tag($maybe_historical);
+ croak encode_utf8("Unknown tag $maybe_historical.")
+ unless defined $tag;
+
+ delete $self->enabled_checks_by_name->{$tag->check}
+ unless exists $self->enabled_tags_by_name->{$tag->name}
+ && --$self->enabled_checks_by_name->{$tag->check};
+
+ delete $self->enabled_tags_by_name->{$tag->name};
+
+ return;
+}
+
+=item read_profile
+
+=cut
+
+sub read_profile {
+ my ($self, $requested_name) = @_;
+
+ my @search_space;
+
+ if (!defined $requested_name) {
+ @search_space = map { "$_/main" } @{$self->known_vendors};
+
+ } elsif ($requested_name !~ m{/}) {
+ @search_space = ("$requested_name/main");
+
+ } elsif ($requested_name =~ m{^[^.]+/[^/.]+$}) {
+ @search_space = ($requested_name);
+
+ } else {
+ croak encode_utf8("$requested_name is not a valid profile name");
+ }
+
+ my @candidates;
+ for my $include_dir ( map { ($_ // q{.}) . '/profiles' }
+ @{$self->include_dirs} ) {
+ push(@candidates, map { "$include_dir/$_.profile" } @search_space);
+ }
+
+ my $path = first_value { -e } @candidates;
+
+ croak encode_utf8(
+ 'Could not find a profile matching: ' . join($SPACE, @search_space))
+ unless length $path;
+
+ my $deb822 = Lintian::Deb822->new;
+ my @paragraphs = $deb822->read_file($path);
+
+ my ($header, @sections) = @paragraphs;
+
+ croak encode_utf8("Profile has no header in $path")
+ unless defined $header;
+
+ my $profile_name = $header->unfolded_value('Profile');
+ croak encode_utf8("Profile has no name in $path")
+ unless length $profile_name;
+
+ croak encode_utf8("Invalid Profile field in $path")
+ if $profile_name =~ m{^/} || $profile_name =~ m{\.};
+
+ # normalize name
+ $profile_name .= '/main'
+ unless $profile_name =~ m{/};
+
+ croak encode_utf8("Recursive definition of $profile_name")
+ if exists $self->parent_map->{$profile_name};
+
+ # Mark as being loaded.
+ $self->parent_map->{$profile_name} = 0;
+
+ $self->name($profile_name)
+ unless length $self->name;
+
+ $self->read_profile($header->unfolded_value('Extends'))
+ if $header->declares('Extends');
+
+ # prepend profile name after loading any parent
+ unshift(@{$self->profile_list}, $profile_name);
+
+ my @have_comma
+ = grep { $header->value($_) =~ / , /sx } @VALID_HEADER_FIELDS;
+ for my $section (@sections) {
+ push(@have_comma,
+ grep { $section->value($_) =~ / , /sx } @VALID_BODY_FIELDS);
+ }
+
+ warn
+"Please use spaces as separators in field $_ instead of commas in profile $path\n"
+ for uniq @have_comma;
+
+ my @unknown_header_fields = $header->extra(@VALID_HEADER_FIELDS);
+ croak encode_utf8("Unknown fields in header of profile $profile_name: "
+ . join($SPACE, @unknown_header_fields))
+ if @unknown_header_fields;
+
+ my @enable_check_patterns
+ = $header->trimmed_list('Enable-Tags-From-Check', $FIELD_SEPARATOR);
+ my @disable_check_patterns
+ = $header->trimmed_list('Disable-Tags-From-Check', $FIELD_SEPARATOR);
+
+ my @enable_checks;
+ for my $pattern (@enable_check_patterns) {
+ push(@enable_checks, match_glob($pattern, $self->known_checks));
+ }
+
+ my @disable_checks;
+ for my $pattern (@disable_check_patterns) {
+ push(@disable_checks, match_glob($pattern, $self->known_checks));
+ }
+
+ my @action_checks = uniq(@enable_checks, @disable_checks);
+
+ # make sure checks are loaded
+ my @needed_checks
+ = grep { !exists $self->check_module_by_name->{$_} } @action_checks;
+
+ croak encode_utf8("Profile $profile_name references unknown checks: "
+ . join($SPACE, @needed_checks))
+ if @needed_checks;
+
+ my @enable_tag_patterns
+ = $header->trimmed_list('Enable-Tags', $FIELD_SEPARATOR);
+ my @disable_tag_patterns
+ = $header->trimmed_list('Disable-Tags', $FIELD_SEPARATOR);
+
+ my @enable_tags;
+ for my $pattern (@enable_tag_patterns) {
+ push(@enable_tags, match_glob($pattern, $self->known_tags));
+ }
+
+ my @disable_tags;
+ for my $pattern (@disable_tag_patterns) {
+ push(@disable_tags, match_glob($pattern, $self->known_tags));
+ }
+
+ push(@enable_tags, @{$self->tag_names_for_check->{$_} // []})
+ for uniq @enable_checks;
+
+ push(@disable_tags, @{$self->tag_names_for_check->{$_} // []})
+ for uniq @disable_checks;
+
+ # disabling after enabling
+ $self->enable_tag($_) for uniq @enable_tags;
+ $self->disable_tag($_) for uniq @disable_tags;
+
+ my $section_number = 2;
+
+ for my $section (@sections){
+
+ my @unknown_fields = $section->extra(@VALID_BODY_FIELDS);
+ croak encode_utf8(
+"Unknown fields in section $section_number of profile $profile_name: "
+ . join($SPACE, @unknown_fields))
+ if @unknown_fields;
+
+ my @tags = $section->trimmed_list('Tags', $FIELD_SEPARATOR);
+ croak encode_utf8(
+"Tags field missing or empty in section $section_number of profile $profile_name"
+ )unless @tags;
+
+ my $overridable = $section->unfolded_value('Overridable') || 'yes';
+ if ($overridable !~ / ^ -? \d+ $ /msx) {
+ my $lowercase = lc $overridable;
+
+ if ($lowercase =~ / ^ y(?:es)? | true $ /msx) {
+ $overridable = 1;
+
+ } elsif ($lowercase =~ / ^ n[o]? | false $ /msx) {
+ $overridable = 0;
+
+ } else {
+ my $position = $section->position('Overridable');
+ croak encode_utf8(
+"$overridable is not a boolean value in profile $profile_name (line $position)"
+ );
+ }
+ }
+
+ for my $tag_name (@tags) {
+
+ if ($overridable) {
+ delete $self->durable_tags_by_name->{$tag_name};
+ } else {
+ $self->durable_tags_by_name->{$tag_name} = 1;
+ }
+ }
+
+ } continue {
+ $section_number++;
+ }
+
+ $self->our_vendor($self->profile_list->[0]);
+
+ # honor tag settings regardless of profile
+ my @show_always
+ = grep { $_->show_always } values %{$self->known_tags_by_name};
+
+ $self->durable_tags_by_name->{$_} = 1 for map { $_->name } @show_always;
+
+ return;
+}
+
+=item display_level_for_tag
+
+=cut
+
+sub display_level_for_tag {
+ my ($self, $tag_name) = @_;
+
+ my $tag = $self->get_tag($tag_name);
+ croak encode_utf8("Unknown tag $tag_name")
+ unless defined $tag;
+
+ return $self->display_level_lookup->{$tag->visibility};
+}
+
+=item tag_is_enabled(TAG)
+
+=cut
+
+sub tag_is_enabled {
+ my ($self, $maybe_historical) = @_;
+
+ my $tag = $self->get_tag($maybe_historical);
+ croak encode_utf8("Unknown tag $maybe_historical.")
+ unless defined $tag;
+
+ return 1
+ if exists $self->enabled_tags_by_name->{$tag->name};
+
+ return 0;
+}
+
+=item display(OPERATION, RELATION, VISIBILITY)
+
+Configure which tags are displayed by visibility. OPERATION
+is C<+> to display the indicated tags, C<-> to not display the indicated
+tags, or C<=> to not display any tags except the indicated ones. RELATION
+is one of C<< < >>, C<< <= >>, C<=>, C<< >= >>, or C<< > >>. The
+OPERATION will be applied to all values of visibility that
+match the given RELATION on the VISIBILITY argument. If
+either of those arguments are undefined, the action applies to any value
+for that variable. For example:
+
+ $tags->display('=', '>=', 'error');
+
+turns off display of all tags and then enables display of any tag of
+visibility error or higher.
+
+ $tags->display('+', '>', 'warning');
+
+adds to the current configuration display of all tags with a visibility
+higher than warning.
+
+ $tags->display('-', '=', 'info');
+
+turns off display of tags of visibility info.
+
+This method throws an exception on errors, such as an unknown visibility or
+an impossible constraint (like C<< > serious >>).
+
+=cut
+
+# Generate a subset of a list given the element and the relation. This
+# function makes a hard assumption that $rel will be one of <, <=, =, >=,
+# or >. It is not syntax-checked.
+sub _relation_subset {
+ my ($self, $element, $rel, @list) = @_;
+
+ if ($rel eq $EQUAL) {
+ return grep { $_ eq $element } @list;
+ }
+
+ if (substr($rel, 0, 1) eq '<') {
+ @list = reverse @list;
+ }
+
+ my $found;
+ for my $i (0..$#list) {
+ if ($element eq $list[$i]) {
+ $found = $i;
+ last;
+ }
+ }
+
+ return ()
+ unless defined($found);
+
+ if (length($rel) > 1) {
+ return @list[$found .. $#list];
+
+ }
+
+ return ()
+ if $found == $#list;
+
+ return @list[($found + 1) .. $#list];
+}
+
+# Given the operation, relation, and visibility, produce a
+# human-readable representation of the display level string for errors.
+sub _format_level {
+ my ($self, $op, $rel, $visibility) = @_;
+
+ if (not defined $visibility) {
+ return "$op $rel";
+ } else {
+ return "$op $rel $visibility (visibility)";
+ }
+}
+
+sub display {
+ my ($self, $op, $rel, $visibility) = @_;
+
+ unless ($op =~ /^[+=-]\z/ and $rel =~ /^(?:[<>]=?|=)\z/) {
+ my $error = $self->_format_level($op, $rel, $visibility);
+ die encode_utf8('invalid display constraint ' . $error);
+ }
+
+ if ($op eq $EQUAL) {
+ for my $s (@Lintian::Tag::VISIBILITIES) {
+ $self->display_level_lookup->{$s} = 0;
+ }
+ }
+
+ my $status = ($op eq $HYPHEN ? 0 : 1);
+
+ my @visibilities;
+ if ($visibility) {
+ @visibilities
+ = $self->_relation_subset($visibility, $rel,
+ @Lintian::Tag::VISIBILITIES);
+ } else {
+ @visibilities = @Lintian::Tag::VISIBILITIES;
+ }
+
+ unless (@visibilities) {
+ my $error = $self->_format_level($op, $rel, $visibility);
+ die encode_utf8('invalid display constraint ' . $error);
+ }
+
+ for my $s (@visibilities) {
+ $self->display_level_lookup->{$s} = $status;
+ }
+
+ return;
+}
+
+=item search_space
+
+=cut
+
+sub search_space {
+ my ($self, $relative) = @_;
+
+ my @base_dirs;
+ for my $vendor (@{ $self->profile_list }) {
+
+ push(@base_dirs, map { "$_/vendors/$vendor" } @{$self->include_dirs});
+ }
+
+ push(@base_dirs, @{$self->include_dirs});
+
+ my @candidates = map { "$_/$relative" } @base_dirs;
+ my @search_space = grep { -e } @candidates;
+
+ return @search_space;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Relation.pm b/lib/Lintian/Relation.pm
new file mode 100644
index 0000000..b7b4b67
--- /dev/null
+++ b/lib/Lintian/Relation.pm
@@ -0,0 +1,788 @@
+# -*- perl -*-
+# Lintian::Relation -- operations on dependencies and relationships
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2004-2009 Russ Allbery <rra@debian.org>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Relation;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(confess);
+use Const::Fast;
+use List::SomeUtils qw(any);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Relation::Predicate;
+
+use Moo;
+use namespace::clean;
+
+use constant {
+ VISIT_PRED_NAME => 0,
+ VISIT_PRED_FULL => 1,
+ VISIT_OR_CLAUSE_FULL => 3,
+ VISIT_STOP_FIRST_MATCH => 4,
+};
+
+const my $EMPTY => q{};
+
+const my $BRANCH_TYPE => 0;
+const my $PREDICATE => 1;
+
+const my $FALSE => 0;
+
+=head1 NAME
+
+Lintian::Relation - Lintian operations on dependencies and relationships
+
+=head1 SYNOPSIS
+
+ my $depends = Lintian::Relation->new('foo | bar, baz');
+ print encode_utf8("yes\n") if $depends->satisfies('baz');
+ print encode_utf8("no\n") if $depends->satisfies('foo');
+
+=head1 DESCRIPTION
+
+This module provides functions for parsing and evaluating package
+relationship fields such as Depends and Recommends for binary packages and
+Build-Depends for source packages. It parses a relationship into an
+internal format and can then answer questions such as "does this
+dependency require that a given package be installed" or "is this
+relationship a superset of another relationship."
+
+A dependency line is viewed as a predicate formula. The comma separator
+means "and", and the alternatives separator means "or". A bare package
+name is the predicate "a package of this name is available". A package
+name with a version clause is the predicate "a package of this name that
+satisfies this version clause is available." Architecture restrictions,
+as specified in Policy for build dependencies, are supported and also
+checked in the implication logic unless the new_norestriction()
+constructor is used. With that constructor, architecture restrictions
+are ignored.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item trunk
+
+=cut
+
+has trunk => (is => 'rw', default => sub { ['AND'] });
+
+=item load (RELATION)
+
+Creates a new Lintian::Relation object corresponding to the parsed
+relationship RELATION. This object can then be used to ask questions
+about that relationship. RELATION may be C<undef> or the empty string, in
+which case the returned Lintian::Relation object is empty (always
+satisfied).
+
+=cut
+
+sub load {
+ my ($self, $condition, $with_restrictions) = @_;
+
+ $condition //= $EMPTY;
+
+ my @trunk = ('AND');
+
+ my @requirements = grep { length } split(/\s*,\s*/, $condition);
+ for my $requirement (@requirements) {
+
+ my @predicates;
+
+ my @alternatives = split(/\s*\|\s*/, $requirement);
+ for my $alternative (@alternatives) {
+
+ my $predicate = Lintian::Relation::Predicate->new;
+ $predicate->parse($alternative, $with_restrictions);
+
+ push(@predicates, ['PRED', $predicate]);
+ }
+
+ push(@trunk, @predicates)
+ if @predicates == 1;
+
+ push(@trunk, ['OR', @predicates])
+ if @predicates > 1;
+ }
+
+ $self->trunk(\@trunk);
+
+ return $self;
+}
+
+=item load_norestriction (RELATION)
+
+Creates a new Lintian::Relation object corresponding to the parsed
+relationship RELATION, ignoring architecture restrictions and restriction
+lists. This should be used in cases where we only care if a dependency is
+present in some cases and we don't want to require that the architectures
+match (such as when checking for proper build dependencies, since if there
+are architecture constraints the maintainer is doing something beyond
+Lintian's ability to analyze) or that the restrictions list match (Lintian
+can't handle dependency implications with build profiles yet). RELATION
+may be C<undef> or the empty string, in which case the returned
+Lintian::Relation object is empty (always satisfied).
+
+=cut
+
+sub load_norestriction {
+ my ($self, $condition) = @_;
+
+ return $self->load($condition, $FALSE);
+}
+
+=item logical_and(RELATION, ...)
+
+Creates a new Lintian::Relation object produced by AND'ing all the
+relations together. Semantically it is the similar to:
+
+ Lintian::Relation->new (join (', ', @relations))
+
+Except it can avoid some overhead and it works if some of the elements
+are Lintian::Relation objects already.
+
+=cut
+
+sub logical_and {
+ my ($self, @conditions) = @_;
+
+ my @tree = ('AND');
+
+ # make sure to add $self
+ for my $condition (@conditions, $self) {
+
+ my $relation;
+
+ if (ref $condition eq $EMPTY) {
+ # allow string conditions
+ $relation = Lintian::Relation->new->load($condition);
+
+ } else {
+ $relation = $condition;
+ }
+
+ next
+ if $relation->is_empty;
+
+ if ( $tree[$BRANCH_TYPE] eq 'AND'
+ && $relation->trunk->[$BRANCH_TYPE] eq 'AND') {
+
+ my @anded = @{$relation->trunk};
+ shift @anded;
+ push(@tree, @anded);
+
+ } else {
+ push(@tree, $relation->trunk);
+ }
+ }
+
+ my $created = Lintian::Relation->new;
+ $created->trunk(\@tree);
+
+ return $created;
+}
+
+=item redundancies()
+
+Returns a list of duplicated elements within the relation object. Each
+element of the returned list will be a reference to an anonymous array
+holding a set of relations considered redundancies of each other. Two
+relations are considered redundancies if one satisfies the other, meaning that
+if one relationship is satisfied, the other is necessarily satisfied.
+This relationship does not have to be commutative: the opposite
+implication may not hold.
+
+=cut
+
+sub redundancies {
+ my ($self) = @_;
+
+ # there are no redundancies unless the top-level relationship is AND.
+ return ()
+ unless $self->trunk->[$BRANCH_TYPE] eq 'AND';
+
+# The logic here is a bit complex in order to merge sets of duplicate
+# dependencies. We want foo (<< 2), foo (>> 1), foo (= 1.5) to end up as
+# one set of redundancies, even though the first doesn't satisfy the second.
+#
+# $redundant_sets holds a hash, where the key is the earliest dependency in a set
+# and the value is a hash whose keys are the other dependencies in the
+# set. $seen holds a map from package names to the duplicate sets that
+# they're part of, if they're not the earliest package in a set. If
+# either of the dependencies in a duplicate pair were already seen, add
+# the missing one of the pair to the existing set rather than creating a
+# new one.
+ my %redundant_sets;
+
+ my @remaining = @{$self->trunk};
+
+ # discard AND identifier
+ shift @remaining;
+ my $i = 1;
+
+ my %seen;
+ while (@remaining > 1) {
+
+ my $branch_i = shift @remaining;
+ my $j = $i + 1;
+
+ # run against all others
+ for my $branch_j (@remaining) {
+
+ my $forward = implies_array($branch_i, $branch_j);
+ my $reverse = implies_array($branch_j, $branch_i);
+
+ if ($forward or $reverse) {
+ my $one = $self->to_string($branch_i);
+ my $two = $self->to_string($branch_j);
+
+ if ($seen{$one}) {
+ $redundant_sets{$seen{$one}}{$two} = $j;
+ $seen{$two} = $seen{$one};
+
+ } elsif ($seen{$two}) {
+ $redundant_sets{$seen{$two}}{$one} = $i;
+ $seen{$one} = $seen{$two};
+
+ } else {
+ $redundant_sets{$one} ||= {};
+ $redundant_sets{$one}{$two} = $j;
+ $seen{$two} = $one;
+ }
+ }
+ } continue {
+ $j++;
+ }
+ } continue {
+ $i++;
+ }
+
+ return map { [$_, keys %{ $redundant_sets{$_}}] } keys %redundant_sets;
+}
+
+=item restriction_less
+
+Returns a restriction-less variant of this relation.
+
+=cut
+
+sub restriction_less {
+ my ($self) = @_;
+
+ my $unrestricted
+ = Lintian::Relation->new->load_norestriction($self->to_string);
+
+ return $unrestricted;
+}
+
+=item satisfies(RELATION)
+
+Returns true if the relationship satisfies RELATION, meaning that if the
+Lintian::Relation object is satisfied, RELATION will always be satisfied.
+RELATION may be either a string or another Lintian::Relation object.
+
+By default, architecture restrictions are honored in RELATION if it is a
+string. If architecture restrictions should be ignored in RELATION,
+create a Lintian::Relation object with new_norestriction() and pass that
+in as RELATION instead of the string.
+
+=item implies_array
+
+=cut
+
+# This internal function does the heavy of AND, OR, and NOT logic. It expects
+# two references to arrays instead of an object and a relation.
+sub implies_array {
+ my ($p, $q) = @_;
+
+ my $i;
+ my $q0 = $q->[$BRANCH_TYPE];
+ my $p0 = $p->[$BRANCH_TYPE];
+
+ if ($q0 eq 'PRED') {
+ if ($p0 eq 'PRED') {
+ return $p->[$PREDICATE]->satisfies($q->[$PREDICATE]);
+ } elsif ($p0 eq 'AND') {
+ $i = 1;
+ while ($i < @{$p}) {
+ return 1 if implies_array($p->[$i++], $q);
+ }
+ return 0;
+ } elsif ($p0 eq 'OR') {
+ $i = 1;
+ while ($i < @{$p}) {
+ return 0 if not implies_array($p->[$i++], $q);
+ }
+ return 1;
+ } elsif ($p0 eq 'NOT') {
+ return implies_array_inverse($p->[1], $q);
+ }
+ } elsif ($q0 eq 'AND') {
+ # Each of q's clauses must be deduced from p.
+ $i = 1;
+ while ($i < @{$q}) {
+ return 0 if not implies_array($p, $q->[$i++]);
+ }
+ return 1;
+
+ } elsif ($q0 eq 'OR') {
+ # If p is something other than OR, p needs to satisfy one of the
+ # clauses of q. If p is an AND clause, q is satisfied if any of the
+ # clauses of p satisfy it.
+ #
+ # The interesting case is OR. In this case, do an OR to OR comparison
+ # to determine if q's clause is a superset of p's clause as follows:
+ # take each branch of p and see if it satisfies a branch of q. If
+ # each branch of p satisfies some branch of q, return 1. Otherwise,
+ # return 0.
+ #
+ # Simple logic that requires that p satisfy at least one of the
+ # clauses of q considered in isolation will miss that a|b satisfies
+ # a|b|c, since a|b doesn't satisfy any of a, b, or c in isolation.
+ if ($p0 eq 'PRED') {
+ $i = 1;
+ while ($i < @{$q}) {
+ return 1 if implies_array($p, $q->[$i++]);
+ }
+ return 0;
+ } elsif ($p0 eq 'AND') {
+ $i = 1;
+ while ($i < @{$p}) {
+ return 1 if implies_array($p->[$i++], $q);
+ }
+ return 0;
+ } elsif ($p0 eq 'OR') {
+
+ my @p_branches = @{$p};
+ shift @p_branches;
+
+ my @q_branches = @{$q};
+ shift @q_branches;
+
+ for my $p_branch (@p_branches) {
+
+ return 0
+ unless any { implies_array($p_branch, $_) }@q_branches;
+ }
+
+ return 1;
+
+ } elsif ($p->[$BRANCH_TYPE] eq 'NOT') {
+ return implies_array_inverse($p->[1], $q);
+ }
+
+ } elsif ($q0 eq 'NOT') {
+ if ($p0 eq 'NOT') {
+ return implies_array($q->[1], $p->[1]);
+ }
+ return implies_array_inverse($p, $q->[1]);
+ }
+
+ return undef;
+}
+
+# The public interface.
+sub satisfies {
+ my ($self, $condition) = @_;
+
+ my $relation;
+ if (ref $condition eq $EMPTY) {
+ # allow string conditions
+ $relation = Lintian::Relation->new->load($condition);
+
+ } else {
+ $relation = $condition;
+ }
+
+ return implies_array($self->trunk, $relation->trunk) // 0;
+}
+
+=item satisfies_inverse(RELATION)
+
+Returns true if the relationship satisfies that RELATION is certainly false,
+meaning that if the Lintian::Relation object is satisfied, RELATION cannot
+be satisfied. RELATION may be either a string or another
+Lintian::Relation object.
+
+As with satisfies(), by default, architecture restrictions are honored in
+RELATION if it is a string. If architecture restrictions should be
+ignored in RELATION, create a Lintian::Relation object with
+new_norestriction() and pass that in as RELATION instead of the string.
+
+=item implies_array_inverse
+
+=cut
+
+# This internal function does the heavily lifting for AND, OR, and NOT
+# handling for inverse implications. It takes two references to arrays and
+# returns true iff the falsehood of the second can be deduced from the truth
+# of the first.
+sub implies_array_inverse {
+ my ($p, $q) = @_;
+ my $i;
+ my $q0 = $q->[$BRANCH_TYPE];
+ my $p0 = $p->[$BRANCH_TYPE];
+ if ($q0 eq 'PRED') {
+ if ($p0 eq 'PRED') {
+ return $p->[$PREDICATE]->satisfies_inverse($q->[$PREDICATE]);
+ } elsif ($p0 eq 'AND') {
+ # q's falsehood can be deduced from any of p's clauses
+ $i = 1;
+ while ($i < @{$p}) {
+ return 1 if implies_array_inverse($p->[$i++], $q);
+ }
+ return 0;
+ } elsif ($p0 eq 'OR') {
+ # q's falsehood must be deduced from each of p's clauses
+ $i = 1;
+ while ($i < @{$p}) {
+ return 0 if not implies_array_inverse($p->[$i++], $q);
+ }
+ return 1;
+ } elsif ($p0 eq 'NOT') {
+ return implies_array($q, $p->[1]);
+ }
+ } elsif ($q0 eq 'AND') {
+ # Any of q's clauses must be falsified by p.
+ $i = 1;
+ while ($i < @{$q}) {
+ return 1 if implies_array_inverse($p, $q->[$i++]);
+ }
+ return 0;
+ } elsif ($q0 eq 'OR') {
+ # Each of q's clauses must be falsified by p.
+ $i = 1;
+ while ($i < @{$q}) {
+ return 0 if not implies_array_inverse($p, $q->[$i++]);
+ }
+ return 1;
+ } elsif ($q0 eq 'NOT') {
+ return implies_array($p, $q->[1]);
+ }
+
+ return 0;
+}
+
+# The public interface.
+sub satisfies_inverse {
+ my ($self, $condition) = @_;
+
+ my $relation;
+ if (ref $condition eq $EMPTY) {
+ # allow string conditions
+ $relation = Lintian::Relation->new->load($condition);
+
+ } else {
+ $relation = $condition;
+ }
+
+ return implies_array_inverse($self->trunk, $relation->trunk) // 0;
+}
+
+=item to_string
+
+Returns the textual form of a relationship. This converts the internal
+form back into the textual representation and returns that, not the
+original argument, so the spacing is standardized. Returns undef on
+internal failures (such as an object in an unexpected format).
+
+=cut
+
+# The second argument isn't part of the public API. It's a partial relation
+# that's not a blessed object and is used by to_string() internally so that it
+# can recurse.
+sub to_string {
+ my ($self, $branch) = @_;
+
+ my $tree = $branch // $self->trunk;
+
+ my $text;
+ if ($tree->[$BRANCH_TYPE] eq 'PRED') {
+
+ $text = $tree->[$PREDICATE]->to_string;
+
+ } elsif ($tree->[$BRANCH_TYPE] eq 'AND' || $tree->[$BRANCH_TYPE] eq 'OR') {
+
+ my $connector = ($tree->[$BRANCH_TYPE] eq 'AND') ? ', ' : ' | ';
+ my @separated = map { $self->to_string($_) } @{$tree}[1 .. $#{$tree}];
+ $text = join($connector, @separated);
+
+ } elsif ($tree->[$BRANCH_TYPE] eq 'NOT') {
+
+ # currently not generated by any relation
+ $text = '! ' . $tree->[$PREDICATE]->to_string;
+
+ } else {
+ confess encode_utf8("Case $tree->[$BRANCH_TYPE] not implemented");
+ }
+
+ return $text;
+}
+
+=item matches (REGEX[, WHAT])
+
+Check if one of the predicates in this relation matches REGEX. WHAT
+determines what is tested against REGEX and if not given, defaults to
+VISIT_PRED_NAME.
+
+This method will return a truth value if REGEX matches at least one
+predicate or clause (as defined by the WHAT parameter - see below).
+
+NOTE: Often L</satisfies> (or L</satisfies_inverse>) is a better choice
+than this method. This method should generally only be used when
+checking for a "pattern" package (e.g. phpapi-[\d\w+]+).
+
+
+WHAT can be one of:
+
+=over 4
+
+=item VISIT_PRED_NAME
+
+Match REGEX against the package name in each predicate (i.e. version
+and architecture constrains are ignored). Each predicate is tested in
+isolation. As an example:
+
+ my $rel = Lintian::Relation->new ('somepkg | pkg-0 (>= 1)');
+ # Will match (version is ignored)
+ $rel->matches (qr/^pkg-\d$/, VISIT_PRED_NAME);
+
+=item VISIT_PRED_FULL
+
+Match REGEX against the full (normalized) predicate (i.e. including
+version and architecture). Each predicate is tested in isolation.
+As an example:
+
+ my $vrel = Lintian::Relation->new ('somepkg | pkg-0 (>= 1)');
+ my $uvrel = Lintian::Relation->new ('somepkg | pkg-0');
+
+ # Will NOT match (does not match with version)
+ $vrel->matches (qr/^pkg-\d$/, VISIT_PRED_FULL);
+ # Will match (this relation does not have a version)
+ $uvrel->matches (qr/^pkg-\d$/, VISIT_PRED_FULL);
+
+ # Will match (but only because there is a version)
+ $vrel->matches (qr/^pkg-\d \(.*\)$/, VISIT_PRED_FULL);
+ # Will NOT match (there is no version in the relation)
+ $uvrel->matches (qr/^pkg-\d \(.*\)$/, VISIT_PRED_FULL);
+
+=item VISIT_OR_CLAUSE_FULL
+
+Match REGEX against the full (normalized) OR clause. Each predicate
+will have both version and architecture constrains present. As an
+example:
+
+
+ my $vpred = Lintian::Relation->new ('pkg-0 (>= 1)');
+ my $orrel = Lintian::Relation->new ('somepkg | pkg-0 (>= 1)');
+ my $rorrel = Lintian::Relation->new ('pkg-0 (>= 1) | somepkg');
+
+ # Will match
+ $vrel->matches (qr/^pkg-\d(?: \([^\)]\))?$/, VISIT_OR_CLAUSE_FULL);
+ # These Will NOT match (does not match the "|" and the "somepkg" part)
+ $orrel->matches (qr/^pkg-\d(?: \([^\)]\))?$/, VISIT_OR_CLAUSE_FULL);
+ $rorrel->matches (qr/^pkg-\d(?: \([^\)]\))?$/, VISIT_OR_CLAUSE_FULL);
+
+=back
+
+=cut
+
+sub matches {
+ my ($self, $regex, $what) = @_;
+ $what //= VISIT_PRED_NAME;
+ return $self->visit(sub { m/$regex/ }, $what | VISIT_STOP_FIRST_MATCH);
+}
+
+=item equals
+
+Same for full-string matches. Satisfies the perlcritic policy
+RegularExpressions::ProhibitFixedStringMatches.
+
+=cut
+
+sub equals {
+ my ($self, $string, $what) = @_;
+ $what //= VISIT_PRED_NAME;
+ return $self->visit(sub { $_ eq $string }, $what | VISIT_STOP_FIRST_MATCH);
+}
+
+=item visit (CODE[, FLAGS])
+
+Visit clauses or predicates of this relation. Each clause or
+predicate is passed to CODE as first argument and will be available as
+C<$_>.
+
+The optional bitmask parameter, FLAGS, can be used to control what is
+visited and such. If FLAGS is not given, it defaults to
+VISIT_PRED_NAME. The possible values of FLAGS are:
+
+=over 4
+
+=item VISIT_PRED_NAME
+
+The package name in each predicate is visited, but the version and
+architecture part(s) are left out (if any).
+
+=item VISIT_PRED_FULL
+
+The full predicates are visited in turn. The predicate will be
+normalized (by L</to_string>).
+
+=item VISIT_OR_CLAUSE_FULL
+
+CODE will be passed the full OR clauses of this relation. The clauses
+will be normalized (by L</to_string>)
+
+Note: It will not visit the underlying predicates in the clause.
+
+=item VISIT_STOP_FIRST_MATCH
+
+Stop the visits the first time CODE returns a truth value. This is
+similar to L<first|List::Util/first>, except visit will return the
+value returned by CODE.
+
+=back
+
+Except where a given flag specifies otherwise, the return value of
+visit is last value returned by CODE (or C<undef> for the empty
+relation).
+
+=cut
+
+# The last argument is not part of the public API. It's a partial
+# relation that's not a blessed object and is used by visit()
+# internally so that it can recurse.
+
+sub visit {
+ my ($self, $code, $flags, $branch) = @_;
+
+ my $tree = $branch // $self->trunk;
+ my $rel_type = $tree->[$BRANCH_TYPE];
+
+ $flags //= 0;
+
+ if ($rel_type eq 'PRED') {
+ my $predicate = $tree->[$PREDICATE];
+ my $against = $predicate->name;
+ $against = $predicate->to_string
+ if $flags & VISIT_PRED_FULL;
+
+ local $_ = $against;
+ return scalar $code->($against);
+
+ } elsif (($flags & VISIT_OR_CLAUSE_FULL) == VISIT_OR_CLAUSE_FULL
+ and $rel_type eq 'OR') {
+
+ my $against = $self->to_string($tree);
+
+ local $_ = $against;
+ return scalar $code->($against);
+
+ } elsif ($rel_type eq 'AND'
+ or $rel_type eq 'OR'
+ or $rel_type eq 'NOT') {
+
+ for my $rel (@{$tree}[1 .. $#{$tree}]) {
+ my $ret = scalar $self->visit($code, $flags, $rel);
+ if ($ret && ($flags & VISIT_STOP_FIRST_MATCH)) {
+ return $ret;
+ }
+ }
+ return 0;
+ }
+
+ return 0;
+}
+
+=item is_empty
+
+Returns a truth value if this relation is empty (i.e. it contains no
+predicates).
+
+=cut
+
+sub is_empty {
+ my ($self) = @_;
+
+ return 1
+ if $self->trunk->[$BRANCH_TYPE] eq 'AND' && !$self->trunk->[1];
+
+ return 0;
+}
+
+=item unparsable_predicates
+
+Returns a list of predicates that were unparsable.
+
+They are returned in the original textual representation and are also
+sorted by said representation.
+
+=cut
+
+sub unparsable_predicates {
+ my ($self) = @_;
+
+ my @worklist = ($self->trunk);
+ my @unparsable;
+
+ while (my $current = pop(@worklist)) {
+
+ my $rel_type = $current->[$BRANCH_TYPE];
+
+ if ($rel_type ne 'PRED') {
+
+ push(@worklist, @{$current}[1 .. $#{$current}]);
+ next;
+ }
+
+ my $predicate = $current->[$PREDICATE];
+
+ push(@unparsable, $predicate->literal)
+ unless $predicate->parsable;
+ }
+
+ my @sorted = sort @unparsable;
+
+ return @sorted;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Relation/Predicate.pm b/lib/Lintian/Relation/Predicate.pm
new file mode 100644
index 0000000..4714197
--- /dev/null
+++ b/lib/Lintian/Relation/Predicate.pm
@@ -0,0 +1,553 @@
+# -*- perl -*-
+# Lintian::Relation::Predicate -- relationship predicates
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2004-2009 Russ Allbery <rra@debian.org>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020-2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Relation::Predicate;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Relation::Version qw(:all);
+
+use Moo;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $COLON => q{:};
+
+const my $EQUAL => q{=};
+const my $LESS_THAN => q{<};
+const my $LESS_THAN_OR_EQUAL => q{<=};
+const my $DOUBLE_LESS_THAN => q{<<};
+const my $GREATER_THAN => q{>};
+const my $GREATER_THAN_OR_EQUAL => q{>=};
+const my $DOUBLE_GREATER_THAN => q{>>};
+
+const my $LEFT_PARENS => q{(};
+const my $RIGHT_PARENS => q{)};
+const my $LEFT_SQUARE => q{[};
+const my $RIGHT_SQUARE => q{]};
+const my $LEFT_ANGLE => q{<};
+const my $RIGHT_ANGLE => q{>};
+
+const my $TRUE => 1;
+const my $FALSE => 0;
+
+=head1 NAME
+
+Lintian::Relation::Predicate - Lintian type for relationship predicates
+
+=head1 SYNOPSIS
+
+ use Lintian::Relation::Predicate;
+
+=head1 DESCRIPTION
+
+This module provides functions for parsing and evaluating package
+relationships such as Depends and Recommends for binary packages and
+Build-Depends for source packages. It parses a relationship into an
+internal format and can then answer questions such as "does this
+dependency require that a given package be installed" or "is this
+relationship a superset of another relationship."
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item literal
+
+=item C<parsable>
+
+=item name
+
+=item multiarch_qualifier
+
+=item version_operator
+
+=item reference_version
+
+=item build_architecture
+
+=item build_profile
+
+=cut
+
+has literal => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has parsable => (is => 'rw', default => $FALSE);
+
+has name => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has multiarch_qualifier => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has version_operator => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has reference_version => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has build_architecture => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has build_profile => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+=item parse
+
+=cut
+
+# The internal parser which converts a single package element of a
+# relationship into the parsed form used for later processing. We permit
+# substvars to be used as package names so that we can use these routines with
+# the unparsed debian/control file.
+sub parse {
+ my ($self, $text, $with_restrictions) = @_;
+
+ $with_restrictions //= $TRUE;
+
+ # store the element as-is, so we can reconstitute it later
+ $self->literal($text);
+
+ if (
+ $text =~ m{
+ ^\s* # skip leading whitespace
+ ( # package name or substvar (1)
+ (?: # start of the name
+ [a-zA-Z0-9][a-zA-Z0-9+.-]* # start of a package name
+ | # or
+ \$\{[a-zA-Z0-9:-]+\} # substvar
+ ) # end of start of the name
+ (?: # substvars may be mixed in
+ [a-zA-Z0-9+.-]+ # package name portion
+ | # or
+ \$\{[a-zA-Z0-9:-]+\} # substvar
+ )* # zero or more portions or substvars
+ ) # end of package name or substvar
+ (?:[:]([a-z0-9-]+))? # optional Multi-arch arch specification (2)
+ (?: # start of optional version
+ \s* \( # open parenthesis for version part
+ \s* (<<|<=|>=|>>|[=<>]) # relation part (3)
+ \s* ([^\)]+) # version (4)
+ \s* \) # closing parenthesis
+ )? # end of optional version
+ (?: # start of optional architecture
+ \s* \[ # open bracket for architecture
+ \s* ([^\]]+) # architectures (5)
+ \s* \] # closing bracket
+ )? # end of optional architecture
+ (?: # start of optional restriction
+ \s* < # open bracket for restriction
+ \s* ([^,]+) # don't parse restrictions now
+ \s* > # closing bracket
+ )? # end of optional restriction
+ \s* $}x
+ ) {
+ $self->parsable($TRUE);
+
+ $self->name($1);
+ $self->multiarch_qualifier($2);
+ $self->version_operator($3);
+ $self->reference_version($4);
+ $self->build_architecture($5);
+ $self->build_profile($6);
+
+ $self->reference_version($EMPTY)
+ unless length $self->version_operator;
+
+ $self->version_operator($DOUBLE_LESS_THAN)
+ if $self->version_operator eq $LESS_THAN;
+
+ $self->version_operator($DOUBLE_GREATER_THAN)
+ if $self->version_operator eq $GREATER_THAN;
+
+ unless ($with_restrictions) {
+ $self->multiarch_qualifier('any');
+ $self->version_operator($EMPTY);
+ $self->reference_version($EMPTY);
+ $self->build_architecture($EMPTY);
+ $self->build_profile($EMPTY);
+ }
+ }
+
+ return;
+}
+
+=item satisfies
+
+=cut
+
+# This internal function does the heavily lifting of comparing two
+# elements.
+#
+# Takes two elements and returns true iff the second can be deduced from the
+# first. If the second is falsified by the first (in other words, if self
+# actually satisfies not other), return 0. Otherwise, return undef. The 0 return
+# is used by implies_element_inverse.
+sub satisfies {
+ my ($self, $other) = @_;
+
+ if (!$self->parsable || !$other->parsable) {
+
+ return 1
+ if $self->to_string eq $other->to_string;
+
+ return undef;
+ }
+
+ # If the names don't match, there is no relationship between them.
+ return undef
+ if $self->name ne $other->name;
+
+ # the restriction formula forms a disjunctive normal form expression one
+ # way to check whether A <dnf1> satisfies A <dnf2> is to check:
+ #
+ # if dnf1 == dnf1 OR dnf2:
+ # the second dependency is superfluous because the first dependency
+ # applies in all cases the second one applies
+ #
+ # an easy way to check for equivalence of the two dnf expressions would be
+ # to construct the truth table for both expressions ("dnf1" and "dnf1 OR
+ # dnf2") for all involved profiles and then comparing whether they are
+ # equal
+ #
+ # the size of the truth tables grows with 2 to the power of the amount of
+ # involved profile names but since there currently only exist six possible
+ # profile names (see data/fields/build-profiles) that should be okay
+ #
+ # FIXME: we are not doing this check yet so if we encounter a dependency
+ # with build profiles we assume that one does not satisfy the other:
+
+ return undef
+ if length $self->build_profile
+ || length $other->build_profile;
+
+ # If the names match, then the only difference is in the architecture or
+ # version clauses. First, check architecture. The architectures for self
+ # must be a superset of the architectures for other.
+ my @self_arches = split($SPACE, $self->build_architecture);
+ my @other_arches = split($SPACE, $other->build_architecture);
+ if (@self_arches || @other_arches) {
+ my $self_arch_neg = @self_arches && $self_arches[0] =~ /^!/;
+ my $other_arch_neg = @other_arches && $other_arches[0] =~ /^!/;
+
+ # If self has no arches, it is a superset of other and we should fall through
+ # to the version check.
+ if (not @self_arches) {
+ # nothing
+ }
+
+ # If other has no arches, it is a superset of self and there are no useful
+ # implications.
+ elsif (not @other_arches) {
+
+ return undef;
+ }
+
+ # Both have arches. If neither are negated, we know nothing useful
+ # unless other is a subset of self.
+ elsif (not $self_arch_neg and not $other_arch_neg) {
+ my %self_arches = map { $_ => 1 } @self_arches;
+ my $subset = 1;
+ for my $arch (@other_arches) {
+ $subset = 0 unless $self_arches{$arch};
+ }
+
+ return undef
+ unless $subset;
+ }
+
+ # If both are negated, we know nothing useful unless self is a subset of
+ # other (and therefore has fewer things excluded, and therefore is more
+ # general).
+ elsif ($self_arch_neg and $other_arch_neg) {
+ my %other_arches = map { $_ => 1 } @other_arches;
+ my $subset = 1;
+ for my $arch (@self_arches) {
+ $subset = 0 unless $other_arches{$arch};
+ }
+
+ return undef
+ unless $subset;
+ }
+
+ # If other is negated and self isn't, we'd need to know the full list of
+ # arches to know if there's any relationship, so bail.
+ elsif (not $self_arch_neg and $other_arch_neg) {
+
+ return undef;
+ }
+
+# If self is negated and other isn't, other is a subset of self iff none of the
+# negated arches in self are present in other.
+ elsif ($self_arch_neg and not $other_arch_neg) {
+ my %other_arches = map { $_ => 1 } @other_arches;
+ my $subset = 1;
+ for my $arch (@self_arches) {
+ $subset = 0 if $other_arches{substr($arch, 1)};
+ }
+
+ return undef
+ unless $subset;
+ }
+ }
+
+ # Multi-arch architecture specification
+
+ # According to the spec, only the special value "any" is allowed
+ # and it is "recommended" to consider "other such package
+ # relations as unsatisfiable". That said, there seem to be an
+ # interest in supporting ":<arch>" as well, so we will (probably)
+ # have to accept those as well.
+ #
+ # Other than that, we would need to know that the package has the
+ # field "Multi-arch: allowed", but we cannot check that here. So
+ # we assume that it is okay.
+
+ # pkg has no chance of satisfing pkg:Y unless Y is 'any'
+ return undef
+ if !length $self->multiarch_qualifier
+ && length $other->multiarch_qualifier
+ && $other->multiarch_qualifier ne 'any';
+
+ # TODO: Review this case. Are there cases where other cannot
+ # disprove self due to the ":any"-qualifier? For now, we
+ # assume there are no such cases.
+ # pkg:X has no chance of satisfying pkg
+ return undef
+ if length $self->multiarch_qualifier
+ && !length $other->multiarch_qualifier;
+
+ # For now assert that only the identity holds. In practise, the
+ # "pkg:X" (for any valid value of X) seems to satisfy "pkg:any",
+ # fixing that is a TODO (because version clauses complicates
+ # matters)
+ # pkg:X has no chance of satisfying pkg:Y unless X equals Y
+ return undef
+ if length $self->multiarch_qualifier
+ && length $other->multiarch_qualifier
+ && $self->multiarch_qualifier ne $other->multiarch_qualifier;
+
+ # Now, down to version. The implication is true if self's clause is stronger
+ # than other's, or is equivalent.
+
+ # If other has no version clause, then self's clause is always stronger.
+ return 1
+ unless length $other->version_operator;
+
+# If other does have a version clause, then self must also have one to have any
+# useful relationship.
+ return undef
+ unless length $self->version_operator;
+
+ # other wants an exact version, so self must provide that exact version. self
+ # disproves other if other's version is outside the range enforced by self.
+ if ($other->version_operator eq $EQUAL) {
+ if ($self->version_operator eq $DOUBLE_LESS_THAN) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $LESS_THAN_OR_EQUAL) {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $DOUBLE_GREATER_THAN) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_equal($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ }
+ }
+
+# A greater than clause may disprove a less than clause. Otherwise, if
+# self's clause is <<, <=, or =, the version must be <= other's to satisfy other.
+ if ($other->version_operator eq $LESS_THAN_OR_EQUAL) {
+ if ($self->version_operator eq $DOUBLE_GREATER_THAN) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+
+ # Similar, but << is stronger than <= so self's version must be << other's
+ # version if the self relation is <= or =.
+ if ($other->version_operator eq $DOUBLE_LESS_THAN) {
+ if ( $self->version_operator eq $DOUBLE_GREATER_THAN
+ || $self->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ return versions_gte($self->reference_version,
+ $self->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $DOUBLE_LESS_THAN) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+
+ # Same logic as above, only inverted.
+ if ($other->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ if ($self->version_operator eq $DOUBLE_LESS_THAN) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $LESS_THAN_OR_EQUAL) {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+ if ($other->version_operator eq $DOUBLE_GREATER_THAN) {
+ if ( $self->version_operator eq $DOUBLE_LESS_THAN
+ || $self->version_operator eq $LESS_THAN_OR_EQUAL) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $DOUBLE_GREATER_THAN) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+
+ return undef;
+}
+
+=item satisfies_inverse
+
+=cut
+
+# This internal function does the heavy lifting of inverse implication between
+# two elements. Takes two elements and returns true iff the falsehood of
+# the second can be deduced from the truth of the first. In other words, self
+# satisfies not other, or restated, other satisfies not self. (Since if a satisfies b, not b
+# satisfies not a.) Due to the return value of implies_element(), we can let it
+# do most of the work.
+sub satisfies_inverse {
+ my ($self, $other) = @_;
+
+ my $result = $self->satisfies($other);
+ return undef
+ if !defined $result;
+
+ return $result ? 0 : 1;
+}
+
+=item to_string
+
+=cut
+
+sub to_string {
+ my ($self) = @_;
+
+ # return the original value
+ return $self->literal
+ unless $self->parsable;
+
+ my $text = $self->name;
+
+ $text .= $COLON . $self->multiarch_qualifier
+ if length $self->multiarch_qualifier;
+
+ $text
+ .= $SPACE
+ . $LEFT_PARENS
+ . $self->version_operator
+ . $SPACE
+ . $self->reference_version
+ . $RIGHT_PARENS
+ if length $self->version_operator;
+
+ $text.= $SPACE . $LEFT_SQUARE . $self->build_architecture . $RIGHT_SQUARE
+ if length $self->build_architecture;
+
+ $text .= $SPACE . $LEFT_ANGLE . $self->build_profile . $RIGHT_ANGLE
+ if length $self->build_profile;
+
+ return $text;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Relation/Version.pm b/lib/Lintian/Relation/Version.pm
new file mode 100644
index 0000000..d3552b7
--- /dev/null
+++ b/lib/Lintian/Relation/Version.pm
@@ -0,0 +1,213 @@
+# -*- perl -*-
+# Lintian::Relation::Version -- comparison operators on Debian versions
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2004-2009 Russ Allbery <rra@debian.org>
+# Copyright (C) 2009 Adam D. Barratt <adam@adam-barratt.org.uk>
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Relation::Version;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+BEGIN {
+ our @EXPORT_OK = qw(versions_equal versions_lte versions_gte versions_lt
+ versions_gt versions_compare versions_comparator);
+ our %EXPORT_TAGS = ('all' => \@EXPORT_OK);
+}
+
+use AptPkg::Config '$_config';
+use Carp qw(croak);
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $EQUAL => q{=};
+
+my $versioning = do {
+ my $config = AptPkg::Config->new;
+ $config->init;
+ $config->system->versioning;
+};
+
+=head1 NAME
+
+Lintian::Relation::Version - Comparison operators on Debian versions
+
+=head1 SYNOPSIS
+
+ print encode_utf8("yes\n") if versions_equal('1.0', '1.00');
+ print encode_utf8("yes\n") if versions_gte('1.1', '1.0');
+ print encode_utf8("no\n") if versions_lte('1.1', '1.0');
+ print encode_utf8("yes\n") if versions_gt('1.1', '1.0');
+ print encode_utf8("no\n") if versions_lt('1.1', '1.1');
+ print encode_utf8("yes\n") if versions_compare('1.1', '<=', '1.1');
+
+=head1 DESCRIPTION
+
+This module provides five functions for comparing version numbers. The
+underlying implementation uses C<libapt-pkg-perl> to ensure that
+the results match what dpkg will expect.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item versions_equal(A, B)
+
+Returns true if A is equal to B (C<=>) and false otherwise.
+
+=cut
+
+sub versions_equal {
+ my ($p, $q) = @_;
+ my $result;
+
+ return 1 if $p eq $q;
+
+ $result = $versioning->compare($p, $q);
+
+ return ($result == 0);
+}
+
+=item versions_lte(A, B)
+
+Returns true if A is less than or equal (C<< <= >>) to B and false
+otherwise.
+
+=cut
+
+sub versions_lte {
+ my ($p, $q) = @_;
+ my $result;
+
+ return 1 if $p eq $q;
+
+ $result = $versioning->compare($p, $q);
+
+ return ($result <= 0);
+}
+
+=item versions_gte(A, B)
+
+Returns true if A is greater than or equal (C<< >= >>) to B and false
+otherwise.
+
+=cut
+
+sub versions_gte {
+ my ($p, $q) = @_;
+ my $result;
+
+ return 1 if $p eq $q;
+
+ $result = $versioning->compare($p, $q);
+
+ return ($result >= 0);
+}
+
+=item versions_lt(A, B)
+
+Returns true if A is less than (C<<< << >>>) B and false otherwise.
+
+=cut
+
+sub versions_lt {
+ my ($p, $q) = @_;
+ my $result;
+
+ return 0 if $p eq $q;
+
+ $result = $versioning->compare($p, $q);
+
+ return ($result < 0);
+}
+
+=item versions_gt(A, B)
+
+Returns true if A is greater than (C<<< >> >>>) B and false otherwise.
+
+=cut
+
+sub versions_gt {
+ my ($p, $q) = @_;
+ my $result;
+
+ return 0 if $p eq $q;
+
+ $result = $versioning->compare($p, $q);
+
+ return ($result > 0);
+}
+
+=item versions_compare(A, OP, B)
+
+Returns true if A OP B, where OP is one of C<=>, C<< <= >>, C<< >= >>,
+C<<< << >>>, or C<<< >> >>>, and false otherwise.
+
+=cut
+
+sub versions_compare {
+ my ($p, $op, $q) = @_;
+ if ($op eq $EQUAL) { return versions_equal($p, $q) }
+ elsif ($op eq '<=') { return versions_lte($p, $q) }
+ elsif ($op eq '>=') { return versions_gte($p, $q) }
+ elsif ($op eq '<<') { return versions_lt($p, $q) }
+ elsif ($op eq '>>') { return versions_gt($p, $q) }
+ else { croak encode_utf8("unknown operator $op") }
+}
+
+=item versions_comparator (A, B)
+
+Returns -1, 0 or 1 if the version A is (respectively) less than, equal
+to or greater than B. This is useful for (e.g.) sorting a list of
+versions:
+
+ foreach my $version (sort versions_comparator @versions) {
+ ...
+ }
+
+=cut
+
+# Use a prototype to avoid confusing Perl when used with sort.
+
+sub versions_comparator {
+ my ($p, $q) = @_;
+ return $versioning->compare($p, $q);
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian and adapted
+to use libapt-pkg-perl by Adam D. Barratt <adam@adam-barratt-org.uk>.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Reporting/ResourceManager.pm b/lib/Lintian/Reporting/ResourceManager.pm
new file mode 100644
index 0000000..171b6b7
--- /dev/null
+++ b/lib/Lintian/Reporting/ResourceManager.pm
@@ -0,0 +1,233 @@
+# Copyright (C) 2014 Niels Thykier <niels@thykier.net>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+# A simple resource manager for html_reports
+package Lintian::Reporting::ResourceManager;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use File::Basename qw(basename);
+use File::Copy qw(copy);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Util qw(get_file_digest);
+
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $EQUALS => q{=};
+
+const my $BASE64_UNIT => 4;
+const my $WIDELY_READABLE_FOLDER => oct(755);
+
+=head1 NAME
+
+Lintian::Reporting::ResourceManager -- A simple resource manager for html_reports
+
+=head1 SYNOPSIS
+
+ use Lintian::Reporting::ResourceManager;
+
+ my $resMan = Lintian::Reporting::ResourceManager->new(
+ 'html_dir' => 'path/to/HTML-root',
+ );
+ # Copy the resource
+ $resMan->install_resource('path/to/my-image.png', { install_method => 'copy'} );
+ # Move the resource
+ $resMan->install_resource('path/to/generated-styles.css');
+ print encode_utf8('Image: ' . $resMan->resource_url('my-image.png'), "\n");
+ print encode_utf8('CSS: ' . $resMan->resource_url('generated-styles.css'), "\n");
+
+=head1 DESCRIPTION
+
+A simple resource manager for Lintian's reporting tool,
+B<html_reports>.
+
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new(TYPE, OPTS)
+
+Instantiates a new resource manager.
+
+OPTS is a key-value list, which must contain the key "html_dir" set to
+the root of the HTML path. It is beneath this path that all resources
+will be installed
+
+=cut
+
+sub new {
+ my ($class, %opts) = @_;
+ my $self = {%opts,};
+ croak encode_utf8('Missing required parameter html_dir (or it is undef)')
+ if not defined $opts{'html_dir'};
+ $self->{'_resource_cache'} = {};
+ $self->{'_resource_integrity'} = {};
+ return bless($self, $class);
+}
+
+=back
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item install_resource(RESOURCE[, OPT])
+
+Installs RESOURCE into the html root. The resource may be renamed
+(based on content etc.).
+
+Note that the basename of RESOURCE must be unique between all
+resources installed. See L</resource_url(RESOURCE_NAME)>.
+
+If OPT is given, it must be a hashref with 0 or more of the following
+keys (and values).
+
+=over 4
+
+=item install_method
+
+Can be "copy" or "move" (default). If set to "move", the original file
+will be renamed into its new location. Otherwise, a copy is done and
+the original file is left in place.
+
+=item source_file
+
+By default, the path denoted by RESOURCE is both the resource name and
+the source file. This option can be used to install a given file as
+RESOURCE regardless of the basename of the source file.
+
+If this is passed, RESOURCE must be a basename (i.e. without any
+slashes).
+
+=back
+
+=cut
+
+sub install_resource {
+ my ($self, $resource_name, $opt) = @_;
+ my $resource_root = $self->{'html_dir'} . '/resources';
+ my $method = 'move';
+ my ($basename, $install_name, $resource, $digest, $b64digest);
+ $method = $opt->{'install_method'}
+ if $opt && exists($opt->{'install_method'});
+ if ($opt && exists($opt->{'source_file'})) {
+ $basename = $resource_name;
+ $resource = $opt->{'source_file'};
+
+ if ($basename =~ m{ / }msx) {
+
+ croak encode_utf8(
+ join($SPACE,
+ qq(Resource "${resource_name}" must not contain "/"),
+ 'when source_file is given')
+ );
+ }
+ } else {
+ $basename = basename($resource_name);
+ $resource = $resource_name;
+ }
+ $digest = get_file_digest('sha256', $resource);
+ $install_name = $digest->clone->hexdigest;
+ $b64digest = $digest->b64digest;
+
+ while (length($b64digest) % $BASE64_UNIT) {
+ $b64digest .= $EQUALS;
+ }
+
+ croak encode_utf8("Resource name ${basename} already in use")
+ if defined($self->{'_resource_cache'}{$basename});
+ if ($basename =~ m/^.+(\.[^\.]+)$/xsm) {
+ my $ext = $1;
+ $install_name .= $ext;
+ }
+
+ if (!-d $resource_root) {
+ mkdir($resource_root, $WIDELY_READABLE_FOLDER)
+ or die encode_utf8("Cannot mkdir $resource_root");
+ }
+
+ my $target_file = "$resource_root/$install_name";
+ if ($method eq 'move') {
+ rename($resource, $target_file)
+ or die encode_utf8("Cannot rename $resource to $target_file");
+
+ } elsif ($method eq 'copy') {
+ copy($resource, $target_file)
+ or croak encode_utf8("Cannot copy $resource to $target_file: $!");
+ } else {
+ croak encode_utf8(
+ join($SPACE,
+ "Unknown install method ${method}",
+ '- please use "move" or "copy"')
+ );
+ }
+ $self->{'_resource_cache'}{$basename} = $target_file;
+ $self->{'_resource_integrity'}{$basename} = "sha256-${b64digest}";
+ return;
+}
+
+=item resource_url(RESOURCE_NAME)
+
+Returns the path (relative to the HTML root) to a resource installed
+via L</install_resource(RESOURCE)>, where RESOURCE_NAME is the
+basename of the path given to install_resource.
+
+=cut
+
+sub resource_url {
+ my ($self, $resource_name) = @_;
+ croak encode_utf8("Unknown resource $resource_name")
+ if not defined($self->{'_resource_cache'}{$resource_name});
+ return $self->{'_resource_cache'}{$resource_name};
+}
+
+=item resource_integrity_value(RESOURCE_NAME)
+
+Return a string that is valid in the "integrity" field of a C<< <link>
+>> HTML tag. (See https://www.w3.org/TR/SRI/)
+
+=cut
+
+sub resource_integrity_value {
+ my ($self, $resource_name) = @_;
+ croak encode_utf8("Unknown resource $resource_name")
+ if not defined($self->{'_resource_integrity'}{$resource_name});
+ return $self->{'_resource_integrity'}{$resource_name};
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Reporting/Util.pm b/lib/Lintian/Reporting/Util.pm
new file mode 100644
index 0000000..ecf34cf
--- /dev/null
+++ b/lib/Lintian/Reporting/Util.pm
@@ -0,0 +1,217 @@
+# Hey emacs! This is a -*- Perl -*- script!
+# Lintian::Reporting::Util -- Perl utility functions for lintian's reporting framework
+
+# Copyright (C) 1998 Christian Schwarz
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Reporting::Util;
+
+=head1 NAME
+
+Lintian::Reporting::Util - Lintian utility functions
+
+=head1 SYNOPSIS
+
+ use Lintian::Reporting::Util qw(load_state_cache find_backlog);
+
+ my $cache = load_state_cache('path/to/state-dir');
+ my @backlog = find_backlog('2.12', $cache);
+
+=head1 DESCRIPTION
+
+This module contains a number of utility subs that are nice to have
+for the reporting framework, but on their own did not warrant their
+own module.
+
+Most subs are imported only on request.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Exporter qw(import);
+use File::Temp qw(tempfile);
+use List::Util qw(shuffle);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+use YAML::XS ();
+
+use Lintian::Relation::Version qw(versions_equal versions_comparator);
+
+our @EXPORT_OK = (
+ qw(
+ load_state_cache
+ save_state_cache
+ find_backlog
+ )
+);
+
+const my $WIDELY_READABLE => oct(644);
+
+=item load_state_cache(STATE_DIR)
+
+[Reporting tools only] Load the state cache from STATE_DIR.
+
+=cut
+
+sub load_state_cache {
+ my ($state_dir) = @_;
+ my $state_file = "$state_dir/state-cache";
+ my $state = {};
+
+ return $state
+ unless -e $state_file;
+
+ my $yaml = path($state_file)->slurp;
+
+ try {
+ $state = YAML::XS::Load($yaml);
+
+ } catch {
+ # Not sure what Load does in case of issues; perldoc YAML says
+ # very little about it. Based on YAML::Error, I guess it will
+ # write stuff to STDERR and use die/croak, but it remains a
+ # guess.
+ die encode_utf8(
+ "$state_file was invalid; please fix or remove it.\n$@");
+ }
+
+ $state //= {};
+
+ if (ref($state) ne 'HASH') {
+ die encode_utf8("$state_file was invalid; please fix or remove it.");
+ }
+ return $state;
+}
+
+=item save_state_cache(STATE_DIR, STATE)
+
+[Reporting tools only] Save the STATE cache to STATE_DIR.
+
+=cut
+
+sub save_state_cache {
+ my ($state_dir, $state) = @_;
+ my $state_file = "$state_dir/state-cache";
+ my ($tmp_fd, $tmp_path);
+
+ ($tmp_fd, $tmp_path) = tempfile('state-cache-XXXXXX', DIR => $state_dir);
+ ## TODO: Should tmp_fd be binmode'd as we use YAML::XS?
+
+ # atomic replacement of the state file; not a substitute for
+ # proper locking, but it will at least ensure that the file
+ # is in a consistent state.
+ try {
+ print {$tmp_fd} encode_utf8(YAML::XS::Dump($state));
+
+ close($tmp_fd) or die encode_utf8("close $tmp_path: $!");
+
+ # There is no secret in this. Set it to 0644, so it does not
+ # require sudo access on lintian.d.o to read the file.
+ chmod($WIDELY_READABLE, $tmp_path);
+
+ rename($tmp_path, $state_file)
+ or die encode_utf8("rename $tmp_path -> $state_file: $!");
+
+ } catch {
+ my $err = $@;
+ if (-e $tmp_path) {
+ # Ignore error as we have a more important one
+ unlink($tmp_path)
+ or warn encode_utf8("Cannot unlink $tmp_path");
+ }
+ die encode_utf8($err);
+
+ # perlcritic 1.140-1 requires the semicolon on the next line
+ };
+
+ return 1;
+}
+
+=item find_backlog(LINTIAN_VERSION, STATE)
+
+[Reporting tools only] Given the current lintian version and the
+harness state, return a list of group ids that are part of the
+backlog. The list is sorted based on what version of Lintian
+processed the package.
+
+Note the result is by design not deterministic to reduce the
+risk of all large packages being in the same run (e.g. like
+gcc-5 + gcc-5-cross + gcc-6 + gcc-6-cross).
+
+=cut
+
+sub find_backlog {
+ my ($lintian_version, $state) = @_;
+ my (@backlog, %by_version, @low_priority);
+ for my $group_id (keys(%{$state->{'groups'}})) {
+ my $last_version = '0';
+ my $group_data = $state->{'groups'}{$group_id};
+ my $is_out_of_date;
+ # Does this group repeatedly fail with the current version
+ # of lintian?
+ if ( exists($group_data->{'processing-errors'})
+ and $group_data->{'processing-errors'} > 2
+ and exists($group_data->{'last-error-by'})
+ and $group_data->{'last-error-by'} ne $lintian_version) {
+ # To avoid possible "starvation", we will give lower priority
+ # to packages that repeatedly fail. They will be retried as
+ # the backlog is cleared.
+ push(@low_priority, $group_id);
+ next;
+ }
+ if (exists($group_data->{'out-of-date'})) {
+ $is_out_of_date = $group_data->{'out-of-date'};
+ }
+ if (exists($group_data->{'last-processed-by'})) {
+ $last_version = $group_data->{'last-processed-by'};
+ }
+ $is_out_of_date = 1
+ if not versions_equal($last_version, $lintian_version);
+ push(@{$by_version{$last_version}}, $group_id) if $is_out_of_date;
+ }
+ for my $v (sort(versions_comparator keys(%by_version))) {
+ push(@backlog, shuffle(@{$by_version{$v}}));
+ }
+ push(@backlog, shuffle(@low_priority)) if @low_priority;
+ return @backlog;
+}
+
+=back
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen.pm b/lib/Lintian/Screen.pm
new file mode 100644
index 0000000..28d8c85
--- /dev/null
+++ b/lib/Lintian/Screen.pm
@@ -0,0 +1,80 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Screen -- Common facilities for Lintian screens
+
+=head1 SYNOPSIS
+
+ use Moo;
+ use namespace::clean;
+
+ with('Lintian::Screen');
+
+=head1 DESCRIPTION
+
+A class for masking Lintian tags after they are issued
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item name
+
+=item advocates
+
+=item reason
+
+=item see_also
+
+=cut
+
+has name => (is => 'rw', default => sub { {} });
+has advocates => (is => 'rw', default => sub { {} });
+has reason => (is => 'rw', default => sub { {} });
+has see_also => (is => 'rw', default => sub { {} });
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Autotools/LongLines.pm b/lib/Lintian/Screen/Autotools/LongLines.pm
new file mode 100644
index 0000000..1de9b85
--- /dev/null
+++ b/lib/Lintian/Screen/Autotools/LongLines.pm
@@ -0,0 +1,61 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Autotools::LongLines;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ # ./configure script in source root only
+ return 1
+ if $item->name eq 'configure'
+ && ( defined $processable->patched->resolve_path('configure.in')
+ || defined $processable->patched->resolve_path('configure.ac'));
+
+ # Automake's Makefile.in in any folder
+ return 1
+ if $item->basename eq 'Makefile.in'
+ && defined $processable->patched->resolve_path(
+ $item->dirname . '/Makefile.am');
+
+ # any m4 macro as long as ./configure is present
+ return 1
+ if $item->name =~ m{^ m4/ }x
+ && defined $processable->patched->resolve_path('configure');
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Coq/Cmxs/Prerequisites.pm b/lib/Lintian/Screen/Coq/Cmxs/Prerequisites.pm
new file mode 100644
index 0000000..aaf4600
--- /dev/null
+++ b/lib/Lintian/Screen/Coq/Cmxs/Prerequisites.pm
@@ -0,0 +1,49 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Coq::Cmxs::Prerequisites;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ return 1
+ if $item->name =~ m{ [.]cmxs $}x
+ && ( $processable->type eq 'binary'
+ || $processable->type eq 'udeb');
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Emacs/Elpa/Scripts.pm b/lib/Lintian/Screen/Emacs/Elpa/Scripts.pm
new file mode 100644
index 0000000..a943620
--- /dev/null
+++ b/lib/Lintian/Screen/Emacs/Elpa/Scripts.pm
@@ -0,0 +1,50 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Emacs::Elpa::Scripts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ return 1
+ if $item->name =~ m{^usr/lib/emacsen-common/packages/}
+ && ( $processable->type eq 'binary'
+ || $processable->type eq 'udeb')
+ && $processable->relation('strong')->satisfies('emacsen-common');
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Examples/InTests.pm b/lib/Lintian/Screen/Examples/InTests.pm
new file mode 100644
index 0000000..c1bc63f
--- /dev/null
+++ b/lib/Lintian/Screen/Examples/InTests.pm
@@ -0,0 +1,47 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Examples::InTests;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ return 1
+ if $item->name =~ m{^ test s? / }x;
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Examples/Ship/Devhelp.pm b/lib/Lintian/Screen/Examples/Ship/Devhelp.pm
new file mode 100644
index 0000000..2727628
--- /dev/null
+++ b/lib/Lintian/Screen/Examples/Ship/Devhelp.pm
@@ -0,0 +1,47 @@
+# Copyright (C) 2022 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Examples::Ship::Devhelp;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ return 1
+ if $item->name =~ m{^ usr/share/doc/ [^/]+ /examples/ }x;
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Glibc/Control/Ldconfig.pm b/lib/Lintian/Screen/Glibc/Control/Ldconfig.pm
new file mode 100644
index 0000000..403d940
--- /dev/null
+++ b/lib/Lintian/Screen/Glibc/Control/Ldconfig.pm
@@ -0,0 +1,45 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Glibc::Control::Ldconfig;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ return 1
+ if $processable->source_name eq 'glibc';
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Python/Egg/Metadata.pm b/lib/Lintian/Screen/Python/Egg/Metadata.pm
new file mode 100644
index 0000000..facff08
--- /dev/null
+++ b/lib/Lintian/Screen/Python/Egg/Metadata.pm
@@ -0,0 +1,53 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Python::Egg::Metadata;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ return 1
+ if $item->dirname =~ m{ [^/] [.] dist-info / $}x
+ && defined $item->parent_dir->child('METADATA')
+ && defined $item->parent_dir->child('WHEEL');
+
+ return 1
+ if $item->dirname =~ m{ [^/] [.] egg-info / $}x
+ && defined $item->parent_dir->child('PKG-INFO');
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Toolchain/Gnat/AliReadOnly.pm b/lib/Lintian/Screen/Toolchain/Gnat/AliReadOnly.pm
new file mode 100644
index 0000000..682f549
--- /dev/null
+++ b/lib/Lintian/Screen/Toolchain/Gnat/AliReadOnly.pm
@@ -0,0 +1,52 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Toolchain::Gnat::AliReadOnly;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ return 1
+ if $item->name
+ =~ m{^ usr/lib/ [^/]+ /ada/adalib/ [^/]+ / [^/]+ [.] ali \b }x
+ && ( $processable->type eq 'binary'
+ || $processable->type eq 'udeb')
+ && $processable->name =~ /-dev$/
+ && $processable->relation('strong')->satisfies('gnat');
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Screen/Web/Cgi/Scripts.pm b/lib/Lintian/Screen/Web/Cgi/Scripts.pm
new file mode 100644
index 0000000..f667111
--- /dev/null
+++ b/lib/Lintian/Screen/Web/Cgi/Scripts.pm
@@ -0,0 +1,48 @@
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Screen::Web::Cgi::Scripts;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Moo;
+use namespace::clean;
+
+with 'Lintian::Screen';
+
+sub suppress {
+ my ($self, $processable, $hint) = @_;
+
+ my $item = $hint->pointer->item;
+
+ return 1
+ if ($item->is_script || $item->is_elf)
+ && $item->name =~ m{^ usr/lib/cgi-bin/ }x;
+
+ return 0;
+}
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/SlidingWindow.pm b/lib/Lintian/SlidingWindow.pm
new file mode 100644
index 0000000..2274d78
--- /dev/null
+++ b/lib/Lintian/SlidingWindow.pm
@@ -0,0 +1,171 @@
+# -*- perl -*-
+
+# Copyright (C) 2013 Bastien ROUCARIES
+# Copyright (C) 2021 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::SlidingWindow;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Moo;
+use namespace::clean;
+
+const my $DEFAULT_BLOCK_SIZE => 4096;
+const my $EMPTY => q{};
+
+has handle => (is => 'rw');
+has blocksize => (is => 'rw', default => $DEFAULT_BLOCK_SIZE);
+has blocknumber => (is => 'rw', default => -1);
+has blocksub => (is => 'rw', default => undef);
+has _queue => (is => 'rw', default => sub {[q{}, q{}]});
+
+sub readwindow {
+ my ($self) = @_;
+ my $window;
+
+ my $first = $self->blocknumber < 0;
+ {
+ # This path is too hot for autodie at its current performance
+ # (at the time of writing, that would be autodie/2.23).
+ # - Benchmark chromium-browser/32.0.1700.123-2/source
+ no autodie qw(read);
+ my $blocksize = $self->blocksize;
+ # Read twice the amount in the first window and split that
+ # into "two parts". That way we avoid half a block followed
+ # by a full block with the first half being identical to the
+ # previous one.
+ $blocksize *= 2 if $first;
+ my $res = read($self->handle, $window, $blocksize);
+ if (not $res) {
+ die encode_utf8("read failed: $!\n") unless defined($res);
+ return;
+ }
+ }
+
+ if(defined($self->blocksub)) {
+ local $_ = $window;
+ $self->blocksub->();
+ $window = $_;
+ }
+
+ $self->blocknumber($self->blocknumber + 1);
+
+ if ($first && $self->blocksize < length($window)) {
+ # Split the first block into two windows. We assume here that
+ # if the two halves are not of equal length, then it is
+ # because the file is shorter than 2*blocksize. In this case,
+ # make the second half the shorter (it shouldn't matter and it
+ # is easier to do this way).
+ my $blocksize = $self->blocksize;
+ $self->_queue->[0] = substr($window, 0, $blocksize);
+ $self->_queue->[1] = substr($window, $blocksize);
+ return $window;
+ }
+ shift(@{$self->_queue});
+ push(@{$self->_queue}, $window);
+ return join($EMPTY, @{$self->_queue});
+}
+
+=head1 NAME
+
+Lintian::SlidingWindow - Lintian interface to sliding window match
+
+=head1 SYNOPSIS
+
+ use Lintian::SlidingWindow;
+
+ my $sfd = Lintian::SlidingWindow->new('<','someevilfile.c', sub { $_ = lc($_); });
+ my $window;
+ while ($window = $sfd->readwindow) {
+ if (index($window, 'evil') > -1) {
+ if($window =~
+ m/software \s++ shall \s++
+ be \s++ used \s++ for \s++ good \s*+ ,?+ \s*+
+ not \s++ evil/xsim) {
+ # do something like : tag 'license-problem-json-evil';
+ }
+ }
+ }
+
+=head1 DESCRIPTION
+
+Lintian::SlidingWindow provides a way of matching some pattern,
+including multi line pattern, without needing to fully load the
+file in memory.
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new(HANDLE[, BLOCKSUB[, BLOCKSIZE]])
+
+Create a new sliding window by reading from a given HANDLE, which must
+be open for reading. Optionally run BLOCKSUB against each block. Note
+that BLOCKSUB should apply transform byte by byte and does not depend
+of context.
+
+Each window consists of up to two blocks of BLOCKSIZE characters.
+
+=back
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item readwindow
+
+Return a new block of sliding window. Return undef at end of file.
+
+=item C<blocksize>
+
+=item blocknumber
+
+=item handle
+
+=item blocksub
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item no data type specified
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Bastien ROUCARIES for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Spelling.pm b/lib/Lintian/Spelling.pm
new file mode 100644
index 0000000..1a8d7fc
--- /dev/null
+++ b/lib/Lintian/Spelling.pm
@@ -0,0 +1,295 @@
+# -*- perl -*-
+# Lintian::Spelling -- Lintian spelling checks shared between multiple scripts
+
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2004 Marc Brockschmidt
+# Copyright (C) 1998 Richard Braakman
+# Copyright (C) 2023 Axel Beckert
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Spelling;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+our @EXPORT_OK = qw(
+ check_spelling
+ check_spelling_picky
+);
+
+use Carp qw(croak);
+use Const::Fast;
+use Unicode::UTF8 qw(encode_utf8);
+
+const my $SPACE => q{ };
+const my $DOUBLE_QUOTE => q{"};
+
+=head1 NAME
+
+Lintian::Spelling -- Lintian spell checks shared between multiple scripts
+
+=head1 SYNOPSIS
+
+ use Lintian::Spelling qw(check_spelling);
+
+=head1 DESCRIPTION
+
+This module provides functions to do some Lintian checks that need to be
+done in multiple places. There are certain low-level checks, such as
+validating a maintainer name and e-mail address or checking spelling,
+which apply in multiple situations and should be done in multiple checks
+scripts or in checks scripts and the Lintian front-end.
+
+The functions provided by this module issue tags directly, usually either
+taking the tag name to issue as an argument or dynamically constructing
+the tag name based on function parameters. The caller is responsible for
+ensuring that all tags are declared in the relevant *.desc file with
+proper descriptions and other metadata. The possible tags issued by each
+function are described in the documentation for that function.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item check_spelling(TEXT,[ EXCEPTIONS,] CODEREF)
+
+Performs a spelling check of TEXT. Call CODEREF once for each unique
+misspelling with the following arguments:
+
+=over 4
+
+=item The misspelled word/phrase
+
+=item The correct word/phrase
+
+=back
+
+If EXCEPTIONS is given, it will be used as an array ref of exceptions.
+Any lowercase word appearing as a key of that array will never be
+considered a spelling mistake (exception being if it is a part of a
+multiword misspelling).
+
+Returns the number of spelling mistakes found in TEXT.
+
+=cut
+
+my (%CORRECTIONS, @CORRECTIONS_MULTIWORD);
+
+sub check_spelling {
+ my ($data, $text, $acceptable, $code_ref, $duplicate_check) = @_;
+
+ croak encode_utf8('No spelling data')
+ unless defined $data;
+
+ return 0
+ unless $text;
+
+ if ( !defined $code_ref
+ && defined $acceptable
+ && ref($acceptable) eq 'CODE') {
+ $code_ref = $acceptable;
+ $acceptable = [];
+ }
+
+ $acceptable //= [];
+ $duplicate_check //= 1;
+
+ my %exceptions = map { $_ => 1 } @{$acceptable};
+
+ my (%seen, %duplicates, $last_word, $quoted);
+ my $counter = 0;
+ my $text_orig = $text;
+
+ if (!%CORRECTIONS) {
+ my $corrections_multiword
+ = $data->load('spelling/corrections-multiword', '\|\|');
+ my $corrections = $data->load('spelling/corrections', '\|\|');
+ for my $misspelled ($corrections->all) {
+ $CORRECTIONS{$misspelled} = $corrections->value($misspelled);
+ }
+ for my $misspelled_regex ($corrections_multiword->all) {
+ my $correct = $corrections_multiword->value($misspelled_regex);
+ push(@CORRECTIONS_MULTIWORD,
+ [qr/\b($misspelled_regex)\b/, $correct]);
+ }
+ }
+
+ $text =~ tr/[]//d;
+ # Strip () except for "(s)" suffixes.
+ $text =~ s/(\((?!s\))|(?<!\(s)\))//gi;
+ $text =~ s/(\w-)\s*\n\s*/$1/;
+ $text =~ tr/\r\n \t/ /s;
+ $text =~ s/\s++/ /g;
+
+ # trim both ends
+ $text =~ s/^\s+|\s+$//g;
+
+ for my $word (split($SPACE, $text)) {
+ my $ends_with_punct = 0;
+ my $q = $word =~ tr/"/"/;
+ # Change quoting on "foo or foo" but not "foo".
+ if ($q & 1) {
+ $quoted = not $quoted;
+ }
+ $ends_with_punct = 1 if $word =~ s/[.,;:?!]+$//;
+
+ if ($duplicate_check and defined($last_word) and $last_word eq $word) {
+ # Avoid flagging words inside quoted text.
+ $code_ref->("$word $word (duplicate word)", $word)
+ if not $quoted
+ and not $duplicates{$word}++
+ and not $ends_with_punct
+ and $text_orig !~ /\b$word\s*\($word\b/
+ and $text_orig !~ /\b$word\)\s*$word\b/;
+ }
+
+ if ($word =~ m/^[A-Za-z]+$/ and not $ends_with_punct) {
+ $last_word = $word;
+ } else {
+ $last_word = undef;
+ }
+
+ next
+ if $word =~ /^[A-Z]{1,5}\z/;
+
+ # Some exceptions are based on case (e.g. "teH").
+ next
+ if exists $exceptions{$word};
+
+ my $lcword = lc $word;
+ if (exists $CORRECTIONS{$lcword}
+ && !exists $exceptions{$lcword}) {
+
+ $counter++;
+ my $correction = $CORRECTIONS{$lcword};
+
+ if ($word =~ /^[A-Z]+$/) {
+ $correction = uc $correction;
+ } elsif ($word =~ /^[A-Z]/) {
+ $correction = ucfirst $correction;
+ }
+
+ next
+ if $seen{$lcword}++;
+
+ $code_ref->($word, $correction);
+ }
+ }
+
+ # Special case for correcting multi-word strings.
+ for my $cm (@CORRECTIONS_MULTIWORD) {
+ my ($oregex, $correction) = @{$cm};
+ if ($text =~ $oregex) {
+ my $word = $1;
+ if ($word =~ /^[A-Z]+$/) {
+ $correction = uc $correction;
+ } elsif ($word =~ /^[A-Z]/) {
+ $correction = ucfirst $correction;
+ }
+ $counter++;
+ next if $seen{lc $word}++;
+ $code_ref->(
+ $DOUBLE_QUOTE . $word . $DOUBLE_QUOTE,
+ $DOUBLE_QUOTE . $correction . $DOUBLE_QUOTE
+ );
+ }
+ }
+
+ return $counter;
+}
+
+=item check_spelling_picky(TEXT, CODEREF)
+
+Performs a spelling check of TEXT. Call CODEREF once for each unique
+misspelling with the following arguments:
+
+=over 4
+
+=item The misspelled word/phrase
+
+=item The correct word/phrase
+
+=back
+
+This method performs some pickier corrections - such as checking for common
+capitalization mistakes - which would are not included in check_spelling as
+they are not appropriate for some files, such as changelogs.
+
+Returns the number of spelling mistakes found in TEXT.
+
+=cut
+
+sub check_spelling_picky {
+ my ($data, $text, $code_ref) = @_;
+
+ croak encode_utf8('No spelling data')
+ unless defined $data;
+
+ my %seen;
+ my $counter = 0;
+ my $corrections_case= $data->load('spelling/corrections-case', '\|\|');
+
+ # Check this first in case it's contained in square brackets and
+ # removed below.
+ if ($text =~ /meta\s+package/) {
+ $counter++;
+ $code_ref->('meta package', 'metapackage');
+ }
+
+ # Exclude text enclosed in square brackets as it could be a package list
+ # or similar which may legitimately contain lower-cased versions of
+ # the words.
+ $text =~ s/\[.+?\]//sg;
+ $text =~ tr/\r\n \t/ /s;
+ $text =~ s/\s++/ /g;
+
+ # trim both ends
+ $text =~ s/^\s+|\s+$//g;
+
+ for my $word (split(/\s+/, $text)) {
+ $word =~ s/^\(|[).,?!:;]+$//g;
+ if ($corrections_case->recognizes($word)) {
+ $counter++;
+ next if $seen{$word}++;
+ $code_ref->($word, $corrections_case->value($word));
+ }
+ }
+
+ return $counter;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian. Based on
+code from checks scripts by Marc Brockschmidt and Richard Braakman.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Storage/MLDBM.pm b/lib/Lintian/Storage/MLDBM.pm
new file mode 100644
index 0000000..f58cb8c
--- /dev/null
+++ b/lib/Lintian/Storage/MLDBM.pm
@@ -0,0 +1,128 @@
+# -*- perl -*- Lintian::Storage::MLDBM
+#
+# Copyright (C) 2022 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Storage::MLDBM;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use BerkeleyDB;
+use Const::Fast;
+use MLDBM qw(BerkeleyDB::Btree Storable);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8 decode_utf8);
+
+const my $EMPTY => q{};
+const my $HYPHEN => q{-};
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Storage::MLDBM - store multi-level hashes on disk
+
+=head1 SYNOPSIS
+
+ use Lintian::Storage::MLDBM;
+
+=head1 DESCRIPTION
+
+Lintian::Storage::MLDBM provides an interface to store data on disk to preserve memory.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item tempfile
+
+=item tied_hash
+
+=cut
+
+has tempfile => (is => 'rw');
+has tied_hash => (is => 'rw', default => sub { {} });
+
+=item create
+
+=cut
+
+sub create {
+ my ($self, $description) = @_;
+
+ $description //= $EMPTY;
+
+ $description .= $HYPHEN
+ if length $description;
+
+ my $stem = "mldbm-$description";
+
+ my $tempfile
+ = Path::Tiny->tempfile(TEMPLATE => $stem . 'XXXXXXXX', UNLINK => 0);
+ $self->tempfile($tempfile);
+
+ try {
+ tie(
+ %{$self->tied_hash}, 'MLDBM',
+ -Filename => $tempfile->stringify,
+ -Flags => DB_CREATE
+ );
+
+ } catch {
+ die encode_utf8("Cannot create database in $tempfile: $@");
+ };
+
+ return;
+}
+
+=item DEMOLISH
+
+=cut
+
+sub DEMOLISH {
+ my ($self, $in_global_destruction) = @_;
+
+ untie %{$self->tied_hash};
+
+ $self->tempfile->remove
+ if defined $self->tempfile;
+
+ return;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Tag.pm b/lib/Lintian/Tag.pm
new file mode 100644
index 0000000..7c93086
--- /dev/null
+++ b/lib/Lintian/Tag.pm
@@ -0,0 +1,297 @@
+# -*- perl -*-
+# Lintian::Tag -- interface to tag metadata
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2009 Russ Allbery
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Tag;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Email::Address::XS;
+use List::SomeUtils qw(none first_value);
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Deb822;
+
+use Moo;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SLASH => q{/};
+
+# Ordered lists of visibilities, used for display level parsing.
+our @VISIBILITIES= qw(classification pedantic info warning error);
+
+=head1 NAME
+
+Lintian::Tag - Lintian interface to tag metadata
+
+=head1 SYNOPSIS
+
+ my $tag = Lintian::Tag->new;
+
+=head1 DESCRIPTION
+
+This module provides an interface to tag metadata as gleaned from the
+*.desc files describing the checks. It can be used to retrieve specific
+metadata elements or to format the tag description.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item name
+
+=item visibility
+
+=item check
+
+=item name_spaced
+
+=item show_always
+
+=item experimental
+
+=item explanation
+
+=item see_also
+
+=item renamed_from
+
+=item profile
+
+=cut
+
+has name => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+has visibility => (
+ is => 'rw',
+ lazy => 1,
+ coerce => sub {
+ my ($text) = @_;
+
+ $text //= $EMPTY;
+ croak encode_utf8("Unknown tag visibility $text")
+ if none { $text eq $_ } @VISIBILITIES;
+
+ return $text;
+ },
+ default => $EMPTY
+);
+
+has check => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+has name_spaced => (
+ is => 'rw',
+ coerce => sub { my ($boolean) = @_; return ($boolean // 0); },
+ default => 0
+);
+
+has show_always => (
+ is => 'rw',
+ coerce => sub { my ($boolean) = @_; return ($boolean // 0); },
+ default => 0
+);
+
+has experimental => (
+ is => 'rw',
+ coerce => sub { my ($boolean) = @_; return ($boolean // 0); },
+ default => 0
+);
+
+has explanation => (
+ is => 'rw',
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); },
+ default => $EMPTY
+);
+
+has see_also => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+has renamed_from => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+has screens => (
+ is => 'rw',
+ coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
+ default => sub { [] }
+);
+
+=item load(PATH)
+
+Loads a tag description from PATH.
+
+=cut
+
+sub load {
+ my ($self, $profile, $tagpath) = @_;
+
+ croak encode_utf8('No profile')
+ unless defined $profile;
+
+ croak encode_utf8("Cannot read tag file from $tagpath")
+ unless -r $tagpath;
+
+ my $deb822 = Lintian::Deb822->new;
+ my @sections = $deb822->read_file($tagpath);
+
+ my $fields = shift @sections;
+
+ $self->check($fields->value('Check'));
+ $self->name_spaced($fields->value('Name-Spaced') eq 'yes');
+ $self->show_always($fields->value('Show-Always') eq 'yes');
+
+ my $name = $fields->value('Tag');
+ $name = $self->check . $SLASH . $name
+ if $self->name_spaced;
+
+ $self->name($name);
+
+ $self->visibility($fields->value('Severity'));
+ $self->experimental($fields->value('Experimental') eq 'yes');
+
+ $self->explanation($fields->text('Explanation') || $fields->text('Info'));
+
+ my @see_also = $fields->trimmed_list('See-Also', qr{,});
+ @see_also = $fields->trimmed_list('Ref', qr{,})
+ unless @see_also;
+
+ $self->see_also(\@see_also);
+
+ $self->renamed_from([$fields->trimmed_list('Renamed-From')]);
+
+ croak encode_utf8("No Tag field in $tagpath")
+ unless length $self->name;
+
+ my @screens;
+ for my $section (@sections) {
+
+ my $screen_name = $section->value('Screen');
+
+ my $relative = $screen_name;
+ $relative =~ s{^([[:lower:]])}{\U$1};
+ $relative =~ s{/([[:lower:]])}{/\U$1}g;
+ $relative =~ s{-([[:lower:]])}{\U$1}g;
+
+ $relative .= '.pm';
+
+ my @candidates= map {
+ (
+ ($_ // q{.})."/lib/Lintian/Screen/$relative",
+ ($_ // q{.})."/screens/$relative"
+ )
+ } @{$profile->safe_include_dirs};
+
+ my $absolute = first_value { -e } @candidates;
+ die encode_utf8(
+ "Cannot find screen $screen_name (looking for $relative)")
+ unless length $absolute;
+
+ try {
+ require $absolute;
+ } catch {
+ die encode_utf8("Cannot load screen $absolute: $@");
+ }
+
+ my $module = $relative;
+ $module =~ s{ [.]pm $}{}x;
+ $module =~ s{/}{::}g;
+
+ my $screen = "Lintian::Screen::$module"->new;
+
+ $screen->name($screen_name);
+
+ my @advocates= Email::Address::XS->parse($section->value('Advocates'));
+ $screen->advocates(\@advocates);
+
+ $screen->reason($section->text('Reason'));
+
+ my @see_also_screen = $section->trimmed_list('See-Also', qr{,});
+ $screen->see_also(\@see_also_screen);
+
+ push(@screens, $screen);
+ }
+
+ $self->screens(\@screens);
+
+ return;
+}
+
+=item code()
+
+Returns the one-letter code for the tag. This will be a letter chosen
+from C<E>, C<W>, C<I>, or C<P>, based on the tag visibility, and
+other attributes (such as whether experimental is set). This code will
+never be C<O> or C<X>; overrides and experimental tags are handled
+separately.
+
+=cut
+
+# Map visibility levels to tag codes.
+our %CODES = (
+ 'error' => 'E',
+ 'warning' => 'W',
+ 'info' => 'I',
+ 'pedantic' => 'P',
+ 'classification' => 'C',
+);
+
+sub code {
+ my ($self) = @_;
+
+ return $CODES{$self->visibility};
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Util.pm b/lib/Lintian/Util.pm
new file mode 100644
index 0000000..c512451
--- /dev/null
+++ b/lib/Lintian/Util.pm
@@ -0,0 +1,674 @@
+# Hey emacs! This is a -*- Perl -*- script!
+# Lintian::Util -- Perl utility functions for lintian
+
+# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2018-2019 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Util;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Exporter qw(import);
+
+# Force export as soon as possible, since some of the modules we load also
+# depend on us and the sequencing can cause things not to be exported
+# otherwise.
+our @EXPORT_OK;
+
+BEGIN {
+
+ @EXPORT_OK = (
+ qw(
+ get_file_checksum
+ get_file_digest
+ human_bytes
+ perm2oct
+ locate_executable
+ match_glob
+ normalize_pkg_path
+ normalize_link_target
+ is_ancestor_of
+ drain_pipe
+ drop_relative_prefix
+ read_md5sums
+ utf8_clean_log
+ utf8_clean_bytes
+ version_from_changelog
+ $PKGNAME_REGEX
+ $PKGREPACK_REGEX
+ $PKGVERSION_REGEX
+ )
+ );
+}
+
+use Carp qw(croak);
+use Const::Fast;
+use Cwd qw(abs_path);
+use Digest::MD5;
+use Digest::SHA;
+use List::SomeUtils qw(first_value);
+use Path::Tiny;
+use Regexp::Wildcards;
+use Unicode::UTF8 qw(valid_utf8 encode_utf8);
+
+use Lintian::Deb822;
+use Lintian::Changelog;
+use Lintian::Relation::Version qw(versions_equal versions_comparator);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $NEWLINE => qq{\n};
+const my $SLASH => q{/};
+const my $DOT => q{.};
+const my $DOUBLEDOT => q{..};
+const my $BACKSLASH => q{\\};
+
+const my $DEFAULT_READ_SIZE => 4096;
+const my $KIB_UNIT_FACTOR => 1024;
+const my $COMFORT_THRESHOLD => 1536;
+
+const my $OWNER_READ => oct(400);
+const my $OWNER_WRITE => oct(200);
+const my $OWNER_EXECUTE => oct(100);
+const my $SETUID => oct(4000);
+const my $SETUID_OWNER_EXECUTE => oct(4100);
+const my $GROUP_READ => oct(40);
+const my $GROUP_WRITE => oct(20);
+const my $GROUP_EXECUTE => oct(10);
+const my $SETGID => oct(2000);
+const my $SETGID_GROUP_EXECUTE => oct(2010);
+const my $WORLD_READ => oct(4);
+const my $WORLD_WRITE => oct(2);
+const my $WORLD_EXECUTE => oct(1);
+const my $STICKY => oct(1000);
+const my $STICKY_WORLD_EXECUTE => oct(1001);
+
+# preload cache for common permission strings
+# call overhead o perm2oct was measurable on chromium-browser/32.0.1700.123-2
+# load time went from ~1.5s to ~0.1s; of 115363 paths, only 306 were uncached
+# standard file, executable file, standard dir, dir with suid, symlink
+my %OCTAL_LOOKUP = map { $_ => perm2oct($_) } qw(
+ -rw-r--r--
+ -rwxr-xr-x
+ drwxr-xr-x
+ drwxr-sr-x
+ lrwxrwxrwx
+);
+
+my $rw = Regexp::Wildcards->new(type => 'jokers');
+
+=head1 NAME
+
+Lintian::Util - Lintian utility functions
+
+=head1 SYNOPSIS
+
+ use Lintian::Util;
+
+=head1 DESCRIPTION
+
+This module contains a number of utility subs that are nice to have,
+but on their own did not warrant their own module.
+
+Most subs are imported only on request.
+
+=head1 VARIABLES
+
+=over 4
+
+=item $PKGNAME_REGEX
+
+Regular expression that matches valid package names. The expression
+is not anchored and does not enforce any "boundary" characters.
+
+=cut
+
+our $PKGNAME_REGEX = qr/[a-z0-9][-+\.a-z0-9]+/;
+
+=item $PKGREPACK_REGEX
+
+Regular expression that matches "repacked" package names. The expression is
+not anchored and does not enforce any "boundary" characters. It should only
+be applied to the upstream portion (see #931846).
+
+=cut
+
+our $PKGREPACK_REGEX = qr/(dfsg|debian|ds|repack)/;
+
+=item $PKGVERSION_REGEX
+
+Regular expression that matches valid package versions. The
+expression is not anchored and does not enforce any "boundary"
+characters.
+
+=cut
+
+our $PKGVERSION_REGEX = qr{
+ (?: \d+ : )? # Optional epoch
+ [0-9][0-9A-Za-z.+:~]* # Upstream version (with no hyphens)
+ (?: - [0-9A-Za-z.+:~]+ )* # Optional debian revision (+ upstreams versions with hyphens)
+ }xa;
+
+=back
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item drain_pipe(FD)
+
+Reads and discards any remaining contents from FD, which is assumed to
+be a pipe. This is mostly done to avoid having the "write"-end die
+with a SIGPIPE due to a "broken pipe" (which can happen if you just
+close the pipe).
+
+May cause an exception if there are issues reading from the pipe.
+
+Caveat: This will block until the pipe is closed from the "write"-end,
+so only use it with pipes where the "write"-end will eventually close
+their end by themselves (or something else will make them close it).
+
+=cut
+
+sub drain_pipe {
+ my ($fd) = @_;
+ my $buffer;
+
+ 1 while (read($fd, $buffer, $DEFAULT_READ_SIZE) > 0);
+
+ return 1;
+}
+
+=item get_file_digest(ALGO, FILE)
+
+Creates an ALGO digest object that is seeded with the contents of
+FILE. If you just want the hex digest, please use
+L</get_file_checksum(ALGO, FILE)> instead.
+
+ALGO can be 'md5' or shaX, where X is any number supported by
+L<Digest::SHA> (e.g. 'sha256').
+
+This sub is a convenience wrapper around Digest::{MD5,SHA}.
+
+=cut
+
+sub get_file_digest {
+ my ($alg, $file) = @_;
+
+ open(my $fd, '<', $file)
+ or die encode_utf8("Cannot open $file");
+
+ my $digest;
+ if (lc($alg) eq 'md5') {
+ $digest = Digest::MD5->new;
+ } elsif (lc($alg) =~ /sha(\d+)/) {
+ $digest = Digest::SHA->new($1);
+ }
+ $digest->addfile($fd);
+ close($fd);
+
+ return $digest;
+}
+
+=item get_file_checksum(ALGO, FILE)
+
+Returns a hexadecimal string of the message digest checksum generated
+by the algorithm ALGO on FILE.
+
+ALGO can be 'md5' or shaX, where X is any number supported by
+L<Digest::SHA> (e.g. 'sha256').
+
+This sub is a convenience wrapper around Digest::{MD5,SHA}.
+
+=cut
+
+sub get_file_checksum {
+ my @paths = @_;
+
+ my $digest = get_file_digest(@paths);
+
+ return $digest->hexdigest;
+}
+
+=item perm2oct(PERM)
+
+Translates PERM to an octal permission. PERM should be a string describing
+the permissions as done by I<tar t> or I<ls -l>. That is, it should be a
+string like "-rw-r--r--".
+
+If the string does not appear to be a valid permission, it will cause
+a trappable error.
+
+Examples:
+
+ # Good
+ perm2oct('-rw-r--r--') == oct(644)
+ perm2oct('-rwxr-xr-x') == oct(755)
+
+ # Bad
+ perm2oct('broken') # too short to be recognised
+ perm2oct('-resurunet') # contains unknown permissions
+
+=cut
+
+sub perm2oct {
+ my ($text) = @_;
+
+ my $lookup = $OCTAL_LOOKUP{$text};
+ return $lookup
+ if defined $lookup;
+
+ my $octal = 0;
+
+ # Types:
+ # file (-), block/character device (b & c), directory (d),
+ # hardlink (h), symlink (l), named pipe (p).
+ if (
+ $text !~ m{^ [-bcdhlp] # file type
+ ([-r])([-w])([-xsS]) # user
+ ([-r])([-w])([-xsS]) # group
+ ([-r])([-w])([-xtT]) # other
+ }xsm
+ ) {
+ croak encode_utf8("$text does not appear to be a permission string");
+ }
+
+ $octal |= $OWNER_READ if $1 eq 'r';
+ $octal |= $OWNER_WRITE if $2 eq 'w';
+ $octal |= $OWNER_EXECUTE if $3 eq 'x';
+ $octal |= $SETUID if $3 eq 'S';
+ $octal |= $SETUID_OWNER_EXECUTE if $3 eq 's';
+ $octal |= $GROUP_READ if $4 eq 'r';
+ $octal |= $GROUP_WRITE if $5 eq 'w';
+ $octal |= $GROUP_EXECUTE if $6 eq 'x';
+ $octal |= $SETGID if $6 eq 'S';
+ $octal |= $SETGID_GROUP_EXECUTE if $6 eq 's';
+ $octal |= $WORLD_READ if $7 eq 'r';
+ $octal |= $WORLD_WRITE if $8 eq 'w';
+ $octal |= $WORLD_EXECUTE if $9 eq 'x';
+ $octal |= $STICKY if $9 eq 'T';
+ $octal |= $STICKY_WORLD_EXECUTE if $9 eq 't';
+
+ $OCTAL_LOOKUP{$text} = $octal;
+
+ return $octal;
+}
+
+=item human_bytes(SIZE)
+
+=cut
+
+sub human_bytes {
+ my ($size) = @_;
+
+ my @units = qw(B kiB MiB GiB);
+
+ my $unit = shift @units;
+
+ while ($size > $COMFORT_THRESHOLD && @units) {
+
+ $size /= $KIB_UNIT_FACTOR;
+ $unit = shift @units;
+ }
+
+ my $human = sprintf('%.0f %s', $size, $unit);
+
+ return $human;
+}
+
+=item locate_executable (CMD)
+
+=cut
+
+sub locate_executable {
+ my ($command) = @_;
+
+ return $EMPTY
+ unless exists $ENV{PATH};
+
+ my @folders = grep { length } split(/:/, $ENV{PATH});
+ my $path = first_value { -x "$_/$command" } @folders;
+
+ return ($path // $EMPTY);
+}
+
+=item drop_relative_prefix(STRING)
+
+Remove an initial ./ from STRING, if present
+
+=cut
+
+sub drop_relative_prefix {
+ my ($name) = @_;
+
+ my $copy = $name;
+ $copy =~ s{^\./}{}s;
+
+ return $copy;
+}
+
+=item version_from_changelog
+
+=cut
+
+sub version_from_changelog {
+ my ($package_path) = @_;
+
+ my $changelog_path = "$package_path/debian/changelog";
+
+ return $EMPTY
+ unless -e $changelog_path;
+
+ my $contents = path($changelog_path)->slurp_utf8;
+ my $changelog = Lintian::Changelog->new;
+
+ $changelog->parse($contents);
+ my @entries = @{$changelog->entries};
+
+ return $entries[0]->{'Version'}
+ if @entries;
+
+ return $EMPTY;
+}
+
+=item match_glob( $glob, @things_to_test )
+
+Resembles the same semantic as Text::Glob's match_glob(), but with the
+proper escaping of Regexp::Wildcards and pre-configured for Lintian's
+purpose. No more directly having to access module variables either.
+
+=cut
+
+sub match_glob {
+ my ($glob, @things_to_test) = @_;
+ my $re = $rw->convert($glob);
+
+ return grep { /^$re\z/ } @things_to_test;
+}
+
+=item normalize_pkg_path(PATH)
+
+Normalize PATH by removing superfluous path segments. PATH is assumed
+to be relative the package root. Note that the result will never
+start nor end with a slash, even if PATH does.
+
+As the name suggests, this is a path "normalization" rather than a
+true path resolution (for that use Cwd::realpath). Particularly,
+it assumes none of the path segments are symlinks.
+
+normalize_pkg_path will return C<q{}> (i.e. the empty string) if PATH
+is normalized to the root dir and C<undef> if the path cannot be
+normalized without escaping the package root.
+
+=item normalize_link_target(CURDIR, LINK_TARGET)
+
+Normalize the path obtained by following a link with LINK_TARGET as
+its target from CURDIR as the current directory. CURDIR is assumed to
+be relative to the package root. Note that the result will never
+start nor end with a slash, even if CURDIR or DEST does.
+
+normalize_pkg_path will return C<q{}> (i.e. the empty string) if the
+target is the root dir and C<undef> if the path cannot be normalized
+without escaping the package root.
+
+B<CAVEAT>: This function is I<not always sufficient> to test if it is
+safe to open a given symlink. Use C<is_ancestor_of(PARENTDIR, PATH)> for
+that. If you must use this function, remember to check that the
+target is not a symlink (or if it is, that it can be resolved safely).
+
+=cut
+
+sub normalize_link_target {
+ my ($path, $target) = @_;
+
+ if (substr($target, 0, 1) eq $SLASH) {
+ # Link is absolute
+ $path = $target;
+ } else {
+ # link is relative
+ $path = "$path/$target";
+ }
+
+ return normalize_pkg_path($path);
+}
+
+sub normalize_pkg_path {
+ my ($path) = @_;
+
+ return $EMPTY
+ if $path eq $SLASH;
+
+ my @dirty = split(m{/}, $path);
+ my @clean = grep { length } @dirty;
+
+ my @final;
+ for my $component (@clean) {
+
+ if ($component eq $DOT) {
+ # do nothing
+
+ } elsif ($component eq $DOUBLEDOT) {
+ # are we out of bounds?
+ my $discard = pop @final;
+ return undef
+ unless defined $discard;
+
+ } else {
+ push(@final, $component);
+ }
+ }
+
+ # empty if we end in the root
+ my $normalized = join($SLASH, @final);
+
+ return $normalized;
+}
+
+=item is_ancestor_of(PARENTDIR, PATH)
+
+Returns true if and only if PATH is PARENTDIR or a path stored
+somewhere within PARENTDIR (or its subdirs).
+
+This function will resolve the paths; any failure to resolve the path
+will cause a trappable error.
+
+=cut
+
+sub is_ancestor_of {
+ my ($ancestor, $file) = @_;
+
+ my $resolved_file = abs_path($file);
+ croak encode_utf8("resolving $file failed: $!")
+ unless defined $resolved_file;
+
+ my $resolved_ancestor = abs_path($ancestor);
+ croak encode_utf8("resolving $ancestor failed: $!")
+ unless defined $resolved_ancestor;
+
+ my $len;
+ return 1 if $resolved_ancestor eq $resolved_file;
+ # add a slash, "path/some-dir" is not "path/some-dir-2" and this
+ # allows us to blindly match against the root dir.
+ $resolved_file .= $SLASH;
+ $resolved_ancestor .= $SLASH;
+
+ # If $resolved_file is contained within $resolved_ancestor, then
+ # $resolved_ancestor will be a prefix of $resolved_file.
+ $len = length($resolved_ancestor);
+ if (substr($resolved_file, 0, $len) eq $resolved_ancestor) {
+ return 1;
+ }
+ return 0;
+}
+
+=item read_md5sums
+
+=item unescape_md5sum_filename
+
+=cut
+
+sub unescape_md5sum_filename {
+ my ($string, $problematic) = @_;
+
+ # done if there are no escapes
+ return $string
+ unless $problematic;
+
+ # split into individual characters
+ my @array = split(//, $string);
+
+# https://www.gnu.org/software/coreutils/manual/html_node/md5sum-invocation.html
+ my $path;
+ my $escaped = 0;
+ for my $char (@array) {
+
+ # start escape sequence
+ if ($char eq $BACKSLASH && !$escaped) {
+ $escaped = 1;
+ next;
+ }
+
+ # unescape newline
+ $char = $NEWLINE
+ if $char eq 'n' && $escaped;
+
+ # append character
+ $path .= $char;
+
+ # end any escape sequence
+ $escaped = 0;
+ }
+
+ # do not stop inside an escape sequence
+ die encode_utf8('Name terminated inside an escape sequence')
+ if $escaped;
+
+ return $path;
+}
+
+sub read_md5sums {
+ my ($text) = @_;
+
+ my %checksums;
+ my @errors;
+
+ my @lines = split(/\n/, $text);
+
+ while (defined(my $line = shift @lines)) {
+
+ next
+ unless length $line;
+
+ # make sure there are two spaces in between
+ $line =~ /^((?:\\)?\S{32}) (.*)$/;
+
+ my $checksum = $1;
+ my $string = $2;
+
+ unless (length $checksum && length $string) {
+
+ push(@errors, "Odd text: $line");
+ next;
+ }
+
+ my $problematic = 0;
+
+ # leading slash in checksum indicates an escaped name
+ $problematic = 1
+ if $checksum =~ s{^\\}{};
+
+ my $path = unescape_md5sum_filename($string, $problematic);
+
+ push(@errors, "Empty name for checksum $checksum")
+ unless length $path;
+
+ $checksums{$path} = $checksum;
+ }
+
+ return (\%checksums, \@errors);
+}
+
+=item utf8_clean_log
+
+=cut
+
+sub utf8_clean_log {
+ my ($bytes) = @_;
+
+ my $hex_sequence = sub {
+ my ($unclean_bytes) = @_;
+ return '{hex:' . sprintf('%vX', $unclean_bytes) . '}';
+ };
+
+ my $utf8_clean_word = sub {
+ my ($word) = @_;
+ return utf8_clean_bytes($word, $SLASH, $hex_sequence);
+ };
+
+ my $utf8_clean_line = sub {
+ my ($line) = @_;
+ return utf8_clean_bytes($line, $SPACE, $utf8_clean_word);
+ };
+
+ return utf8_clean_bytes($bytes, $NEWLINE, $utf8_clean_line) . $NEWLINE;
+}
+
+=item utf8_clean_bytes
+
+=cut
+
+sub utf8_clean_bytes {
+ my ($bytes, $separator, $utf8_clean_part) = @_;
+
+ my @utf8_clean_parts;
+
+ my $regex = quotemeta($separator);
+ my @parts = split(/$regex/, $bytes);
+
+ for my $part (@parts) {
+
+ if (valid_utf8($part)) {
+ push(@utf8_clean_parts, $part);
+
+ } else {
+ push(@utf8_clean_parts, $utf8_clean_part->($part));
+ }
+ }
+
+ return join($separator, @utf8_clean_parts);
+}
+
+=back
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Version.pm b/lib/Lintian/Version.pm
new file mode 100644
index 0000000..959804f
--- /dev/null
+++ b/lib/Lintian/Version.pm
@@ -0,0 +1,122 @@
+#
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2013 Niels Thykier
+# Copyright (C) 2017 Chris Lamb <lamby@debian.org>
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Version;
+
+use v5.20;
+use warnings;
+use utf8;
+
+our @EXPORT_OK = (
+ qw(
+ guess_version
+ )
+);
+
+use Exporter qw(import);
+
+use Const::Fast;
+use Unicode::UTF8 qw(decode_utf8);
+
+use Lintian::IPC::Run3 qw(safe_qx);
+use Lintian::Util qw(version_from_changelog);
+
+const my $EMPTY => q{};
+
+=head1 NAME
+
+Lintian::Version - routines to determine Lintian version
+
+=head1 SYNOPSIS
+
+ use Lintian::Version;
+
+=head1 DESCRIPTION
+
+Lintian::Version can help guess the current Lintian version.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item guess_version
+
+=cut
+
+sub guess_version {
+ my ($lintian_base) = @_;
+
+ my $guess = version_from_git($lintian_base);
+ $guess ||= version_from_changelog($lintian_base);
+
+ return $guess;
+}
+
+=item version_from_git
+
+=cut
+
+sub version_from_git {
+ my ($source_path) = @_;
+
+ my $git_path = "$source_path/.git";
+
+ return $EMPTY
+ unless -d $git_path;
+
+ # Example outputs:
+ # 2.115.3-49-g086a9a113
+ # 2.115.3-49-g086a9a113-dirty
+ my $describe = decode_utf8(
+ safe_qx('git', "--git-dir=$git_path", 'describe', '--dirty'));
+ chomp $describe;
+
+ # Modify it to make it a valid native version number and make it
+ # look more debianish like these:
+ # 2.115.3+49commits+git086a9a113
+ # 2.115.3+49commits+git086a9a113+dirty
+ my $guess = $describe;
+ $guess =~ s/ - ( \d+ ) -g /+${1}commits+git/sx;
+ $guess =~ s/ - /+/sxg;
+
+ return ($guess // $EMPTY);
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et