From 75808db17caf8b960b351e3408e74142f4c85aac Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Sun, 14 Apr 2024 15:42:30 +0200 Subject: Adding upstream version 2.117.0. Signed-off-by: Daniel Baumann --- lib/Lintian/Check/Apache2.pm | 337 ++++++ lib/Lintian/Check/ApplicationNotLibrary.pm | 141 +++ lib/Lintian/Check/AppstreamMetadata.pm | 269 +++++ lib/Lintian/Check/Apt.pm | 69 ++ lib/Lintian/Check/Archive/File/Name/Length.pm | 93 ++ lib/Lintian/Check/Archive/Liberty/Mismatch.pm | 138 +++ lib/Lintian/Check/Archive/NonFree/Autobuild.pm | 70 ++ lib/Lintian/Check/Binaries.pm | 73 ++ lib/Lintian/Check/Binaries/Architecture.pm | 60 ++ lib/Lintian/Check/Binaries/Architecture/Other.pm | 141 +++ lib/Lintian/Check/Binaries/Corrupted.pm | 93 ++ lib/Lintian/Check/Binaries/DebugSymbols.pm | 72 ++ .../Check/Binaries/DebugSymbols/Detached.pm | 86 ++ lib/Lintian/Check/Binaries/Hardening.pm | 183 ++++ lib/Lintian/Check/Binaries/LargeFileSupport.pm | 108 ++ lib/Lintian/Check/Binaries/Location.pm | 138 +++ lib/Lintian/Check/Binaries/Obsolete/Crypt.pm | 90 ++ lib/Lintian/Check/Binaries/Prerequisites.pm | 214 ++++ lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm | 107 ++ lib/Lintian/Check/Binaries/Prerequisites/Perl.pm | 81 ++ lib/Lintian/Check/Binaries/Prerequisites/Php.pm | 80 ++ lib/Lintian/Check/Binaries/Profiling.pm | 73 ++ lib/Lintian/Check/Binaries/Rpath.pm | 145 +++ lib/Lintian/Check/Binaries/Spelling.pm | 86 ++ lib/Lintian/Check/Binaries/Static.pm | 100 ++ lib/Lintian/Check/BuildSystems/Automake.pm | 54 + lib/Lintian/Check/BuildSystems/Autotools.pm | 88 ++ .../Check/BuildSystems/Autotools/Libtool.pm | 99 ++ lib/Lintian/Check/BuildSystems/Cmake.pm | 73 ++ .../Debhelper/MaintainerScript/Token.pm | 80 ++ lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm | 94 ++ lib/Lintian/Check/BuildSystems/Waf.pm | 87 ++ lib/Lintian/Check/ChangesFile.pm | 121 +++ lib/Lintian/Check/Conffiles.pm | 136 +++ lib/Lintian/Check/ContinuousIntegration/Salsa.pm | 103 ++ lib/Lintian/Check/ControlFiles.pm | 132 +++ lib/Lintian/Check/Cron.pm | 67 ++ lib/Lintian/Check/Cruft.pm | 836 +++++++++++++++ lib/Lintian/Check/DebFormat.pm | 227 ++++ lib/Lintian/Check/Debhelper.pm | 1088 ++++++++++++++++++++ lib/Lintian/Check/Debhelper/Temporary.pm | 55 + lib/Lintian/Check/Debian/Changelog.pm | 970 +++++++++++++++++ lib/Lintian/Check/Debian/Control/Field/Adopted.pm | 98 ++ .../Debian/Control/Field/Architecture/Multiline.pm | 63 ++ .../Check/Debian/Control/Field/BuildProfiles.pm | 110 ++ .../Check/Debian/Control/Field/BuiltUsing.pm | 66 ++ .../Debian/Control/Field/Description/Duplicate.pm | 114 ++ .../Check/Debian/Control/Field/DoubledUp.pm | 83 ++ lib/Lintian/Check/Debian/Control/Field/Empty.pm | 84 ++ .../Check/Debian/Control/Field/Misplaced.pm | 67 ++ .../Check/Debian/Control/Field/Redundant.pm | 68 ++ lib/Lintian/Check/Debian/Control/Field/Relation.pm | 180 ++++ .../Debian/Control/Field/RulesRequiresRoot.pm | 99 ++ lib/Lintian/Check/Debian/Control/Field/Section.pm | 52 + lib/Lintian/Check/Debian/Control/Field/Spacing.pm | 78 ++ lib/Lintian/Check/Debian/Control/Link.pm | 57 + .../Check/Debian/Control/Prerequisite/Circular.pm | 74 ++ .../Debian/Control/Prerequisite/Development.pm | 145 +++ .../Check/Debian/Control/Prerequisite/Redundant.pm | 99 ++ lib/Lintian/Check/Debian/Copyright.pm | 586 +++++++++++ lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm | 105 ++ lib/Lintian/Check/Debian/Copyright/Dep5.pm | 968 +++++++++++++++++ .../Check/Debian/Copyright/Dep5/Components.pm | 109 ++ lib/Lintian/Check/Debian/Debconf.pm | 794 ++++++++++++++ lib/Lintian/Check/Debian/DesktopEntries.pm | 58 ++ lib/Lintian/Check/Debian/Filenames.pm | 78 ++ lib/Lintian/Check/Debian/Files.pm | 60 ++ lib/Lintian/Check/Debian/LineSeparators.pm | 62 ++ lib/Lintian/Check/Debian/LintianOverrides.pm | 64 ++ .../Check/Debian/LintianOverrides/Comments.pm | 88 ++ .../Check/Debian/LintianOverrides/Duplicate.pm | 75 ++ .../Check/Debian/LintianOverrides/Malformed.pm | 52 + .../Check/Debian/LintianOverrides/Mystery.pm | 65 ++ .../Check/Debian/LintianOverrides/Restricted.pm | 80 ++ lib/Lintian/Check/Debian/Maintscript.pm | 73 ++ lib/Lintian/Check/Debian/ManualPages.pm | 67 ++ lib/Lintian/Check/Debian/NotInstalled.pm | 74 ++ lib/Lintian/Check/Debian/Patches.pm | 104 ++ lib/Lintian/Check/Debian/Patches/Count.pm | 54 + lib/Lintian/Check/Debian/Patches/Dep3.pm | 105 ++ lib/Lintian/Check/Debian/Patches/Dpatch.pm | 150 +++ lib/Lintian/Check/Debian/Patches/Quilt.pm | 290 ++++++ lib/Lintian/Check/Debian/PoDebconf.pm | 391 +++++++ lib/Lintian/Check/Debian/Readme.pm | 176 ++++ lib/Lintian/Check/Debian/Rules.pm | 671 ++++++++++++ lib/Lintian/Check/Debian/Rules/DhSequencer.pm | 65 ++ lib/Lintian/Check/Debian/Shlibs.pm | 656 ++++++++++++ lib/Lintian/Check/Debian/Source/IncludeBinaries.pm | 77 ++ lib/Lintian/Check/Debian/SourceDir.pm | 170 +++ lib/Lintian/Check/Debian/Substvars.pm | 55 + lib/Lintian/Check/Debian/Symbols.pm | 83 ++ lib/Lintian/Check/Debian/TrailingWhitespace.pm | 105 ++ lib/Lintian/Check/Debian/Upstream/Metadata.pm | 191 ++++ lib/Lintian/Check/Debian/Upstream/SigningKey.pm | 173 ++++ lib/Lintian/Check/Debian/Variables.pm | 60 ++ lib/Lintian/Check/Debian/VersionSubstvars.pm | 206 ++++ lib/Lintian/Check/Debian/Watch.pm | 379 +++++++ lib/Lintian/Check/Debian/Watch/Standard.pm | 98 ++ lib/Lintian/Check/Debug/Automatic.pm | 63 ++ lib/Lintian/Check/Debug/Obsolete.pm | 70 ++ lib/Lintian/Check/Desktop/Dbus.pm | 189 ++++ lib/Lintian/Check/Desktop/Gnome.pm | 49 + lib/Lintian/Check/Desktop/Gnome/Gir.pm | 166 +++ lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm | 65 ++ lib/Lintian/Check/Desktop/Icons.pm | 69 ++ lib/Lintian/Check/Desktop/X11.pm | 94 ++ lib/Lintian/Check/Desktop/X11/Font/Update.pm | 159 +++ lib/Lintian/Check/DhMake.pm | 83 ++ lib/Lintian/Check/DhMake/Template.pm | 52 + lib/Lintian/Check/Documentation.pm | 246 +++++ lib/Lintian/Check/Documentation/Devhelp.pm | 87 ++ .../Check/Documentation/Devhelp/Standard.pm | 47 + lib/Lintian/Check/Documentation/Doxygen.pm | 75 ++ lib/Lintian/Check/Documentation/Examples.pm | 48 + lib/Lintian/Check/Documentation/Manual.pm | 663 ++++++++++++ lib/Lintian/Check/Documentation/Texinfo.pm | 195 ++++ lib/Lintian/Check/Emacs.pm | 58 ++ lib/Lintian/Check/Emacs/Elpa.pm | 51 + lib/Lintian/Check/Examples.pm | 82 ++ lib/Lintian/Check/Executable.pm | 59 ++ lib/Lintian/Check/Fields/Architecture.pm | 132 +++ lib/Lintian/Check/Fields/Bugs.pm | 62 ++ lib/Lintian/Check/Fields/BuiltUsing.pm | 72 ++ lib/Lintian/Check/Fields/ChangedBy.pm | 66 ++ lib/Lintian/Check/Fields/Checksums.pm | 53 + lib/Lintian/Check/Fields/Deb822.pm | 89 ++ lib/Lintian/Check/Fields/Derivatives.pm | 88 ++ lib/Lintian/Check/Fields/Description.pm | 323 ++++++ lib/Lintian/Check/Fields/Distribution.pm | 167 +++ lib/Lintian/Check/Fields/DmUploadAllowed.pm | 60 ++ lib/Lintian/Check/Fields/Empty.pm | 49 + lib/Lintian/Check/Fields/Essential.pm | 79 ++ lib/Lintian/Check/Fields/Format.pm | 78 ++ lib/Lintian/Check/Fields/Homepage.pm | 101 ++ lib/Lintian/Check/Fields/InstallerMenuItem.pm | 59 ++ lib/Lintian/Check/Fields/Length.pm | 86 ++ lib/Lintian/Check/Fields/MailAddress.pm | 150 +++ lib/Lintian/Check/Fields/Maintainer.pm | 84 ++ lib/Lintian/Check/Fields/Maintainer/Team.pm | 90 ++ lib/Lintian/Check/Fields/MultiArch.pm | 138 +++ lib/Lintian/Check/Fields/MultiLine.pm | 89 ++ lib/Lintian/Check/Fields/Origin.pm | 57 + lib/Lintian/Check/Fields/Package.pm | 61 ++ lib/Lintian/Check/Fields/PackageRelations.pm | 794 ++++++++++++++ lib/Lintian/Check/Fields/PackageType.pm | 58 ++ lib/Lintian/Check/Fields/Priority.pm | 82 ++ lib/Lintian/Check/Fields/Recommended.pm | 142 +++ lib/Lintian/Check/Fields/Required.pm | 144 +++ lib/Lintian/Check/Fields/Section.pm | 140 +++ lib/Lintian/Check/Fields/Source.pm | 99 ++ lib/Lintian/Check/Fields/StandardsVersion.pm | 164 +++ lib/Lintian/Check/Fields/Style.pm | 84 ++ lib/Lintian/Check/Fields/Subarchitecture.pm | 55 + lib/Lintian/Check/Fields/TerminalControl.pm | 62 ++ lib/Lintian/Check/Fields/Trimmed.pm | 52 + lib/Lintian/Check/Fields/Unknown.pm | 86 ++ lib/Lintian/Check/Fields/Uploaders.pm | 71 ++ lib/Lintian/Check/Fields/Urgency.pm | 60 ++ lib/Lintian/Check/Fields/Vcs.pm | 378 +++++++ lib/Lintian/Check/Fields/Version.pm | 100 ++ lib/Lintian/Check/Fields/Version/Derivative.pm | 82 ++ lib/Lintian/Check/Fields/Version/Repack/Count.pm | 65 ++ lib/Lintian/Check/Fields/Version/Repack/Native.pm | 63 ++ lib/Lintian/Check/Fields/Version/Repack/Period.pm | 60 ++ lib/Lintian/Check/Fields/Version/Repack/Tilde.pm | 60 ++ lib/Lintian/Check/Fields/Version/Repack/Typo.pm | 64 ++ lib/Lintian/Check/Files/Architecture.pm | 105 ++ lib/Lintian/Check/Files/Artifact.pm | 140 +++ lib/Lintian/Check/Files/Banned.pm | 113 ++ lib/Lintian/Check/Files/Banned/CompiledHelp.pm | 58 ++ lib/Lintian/Check/Files/Banned/Lenna.pm | 109 ++ lib/Lintian/Check/Files/Bugs.pm | 50 + lib/Lintian/Check/Files/BuildPath.pm | 55 + lib/Lintian/Check/Files/Compressed.pm | 80 ++ lib/Lintian/Check/Files/Compressed/Bz2.pm | 57 + lib/Lintian/Check/Files/Compressed/Gz.pm | 113 ++ lib/Lintian/Check/Files/Compressed/Lz.pm | 77 ++ lib/Lintian/Check/Files/Compressed/Lzma.pm | 57 + lib/Lintian/Check/Files/Compressed/Lzo.pm | 57 + lib/Lintian/Check/Files/Compressed/Xz.pm | 57 + lib/Lintian/Check/Files/Compressed/Zip.pm | 62 ++ lib/Lintian/Check/Files/ConfigScripts.pm | 108 ++ lib/Lintian/Check/Files/Contents.pm | 150 +++ lib/Lintian/Check/Files/Contents/LineLength.pm | 140 +++ lib/Lintian/Check/Files/Date.pm | 66 ++ lib/Lintian/Check/Files/Debug.pm | 55 + lib/Lintian/Check/Files/DebugPackages.pm | 50 + lib/Lintian/Check/Files/Desktop.pm | 57 + lib/Lintian/Check/Files/Duplicates.pm | 88 ++ lib/Lintian/Check/Files/EmptyDirectories.pm | 67 ++ lib/Lintian/Check/Files/EmptyPackage.pm | 159 +++ lib/Lintian/Check/Files/Encoding.pm | 125 +++ lib/Lintian/Check/Files/Generated.pm | 83 ++ lib/Lintian/Check/Files/HardLinks.pm | 57 + lib/Lintian/Check/Files/Hierarchy/Links.pm | 83 ++ lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm | 48 + lib/Lintian/Check/Files/Hierarchy/PathSegments.pm | 57 + lib/Lintian/Check/Files/Hierarchy/Standard.pm | 262 +++++ lib/Lintian/Check/Files/IeeeData.pm | 79 ++ lib/Lintian/Check/Files/Includes.pm | 69 ++ lib/Lintian/Check/Files/Init.pm | 79 ++ lib/Lintian/Check/Files/LdSo.pm | 48 + lib/Lintian/Check/Files/Licenses.pm | 112 ++ lib/Lintian/Check/Files/Locales.pm | 204 ++++ lib/Lintian/Check/Files/Missing.pm | 50 + lib/Lintian/Check/Files/MultiArch.pm | 111 ++ lib/Lintian/Check/Files/Names.pm | 163 +++ lib/Lintian/Check/Files/NonFree.pm | 142 +++ lib/Lintian/Check/Files/ObsoletePaths.pm | 92 ++ lib/Lintian/Check/Files/Openpgp.pm | 51 + lib/Lintian/Check/Files/Ownership.pm | 74 ++ lib/Lintian/Check/Files/P11Kit.pm | 54 + lib/Lintian/Check/Files/Pam.pm | 50 + lib/Lintian/Check/Files/Permissions.pm | 249 +++++ lib/Lintian/Check/Files/Permissions/UsrLib.pm | 54 + lib/Lintian/Check/Files/Pkgconfig.pm | 121 +++ lib/Lintian/Check/Files/PrivacyBreach.pm | 420 ++++++++ lib/Lintian/Check/Files/Scripts.pm | 57 + lib/Lintian/Check/Files/Sgml.pm | 48 + lib/Lintian/Check/Files/SourceMissing.pm | 286 +++++ lib/Lintian/Check/Files/Special.pm | 50 + lib/Lintian/Check/Files/SymbolicLinks.pm | 229 ++++ lib/Lintian/Check/Files/SymbolicLinks/Broken.pm | 119 +++ lib/Lintian/Check/Files/Unicode/Trojan.pm | 134 +++ lib/Lintian/Check/Files/Unwanted.pm | 55 + lib/Lintian/Check/Files/UsrMerge.pm | 53 + lib/Lintian/Check/Files/Vcs.pm | 113 ++ lib/Lintian/Check/Fonts.pm | 92 ++ lib/Lintian/Check/Fonts/Opentype.pm | 95 ++ lib/Lintian/Check/Fonts/Postscript/Type1.pm | 130 +++ lib/Lintian/Check/Fonts/Truetype.pm | 95 ++ lib/Lintian/Check/ForeignOperatingSystems.pm | 63 ++ lib/Lintian/Check/Games.pm | 90 ++ lib/Lintian/Check/GroupChecks.pm | 282 +++++ lib/Lintian/Check/HugeUsrShare.pm | 98 ++ lib/Lintian/Check/Images.pm | 49 + lib/Lintian/Check/Images/Filenames.pm | 126 +++ lib/Lintian/Check/Images/Thumbnails.pm | 56 + lib/Lintian/Check/Includes/ConfigH.pm | 56 + lib/Lintian/Check/InitD.pm | 733 +++++++++++++ lib/Lintian/Check/InitD/MaintainerScript.pm | 147 +++ lib/Lintian/Check/Languages/Fortran/Gfortran.pm | 94 ++ lib/Lintian/Check/Languages/Golang/BuiltUsing.pm | 68 ++ lib/Lintian/Check/Languages/Golang/ImportPath.pm | 56 + lib/Lintian/Check/Languages/Java.pm | 315 ++++++ lib/Lintian/Check/Languages/Java/Bytecode.pm | 58 ++ lib/Lintian/Check/Languages/Javascript/Embedded.pm | 149 +++ lib/Lintian/Check/Languages/Javascript/Nodejs.pm | 262 +++++ .../Check/Languages/Ocaml/ByteCode/Compiled.pm | 85 ++ .../Check/Languages/Ocaml/ByteCode/Interface.pm | 63 ++ .../Check/Languages/Ocaml/ByteCode/Library.pm | 58 ++ .../Languages/Ocaml/ByteCode/Misplaced/Package.pm | 126 +++ .../Languages/Ocaml/ByteCode/Misplaced/Path.pm | 105 ++ .../Check/Languages/Ocaml/ByteCode/Plugin.pm | 56 + .../Check/Languages/Ocaml/CustomExecutable.pm | 59 ++ lib/Lintian/Check/Languages/Ocaml/Meta.pm | 67 ++ lib/Lintian/Check/Languages/Perl.pm | 125 +++ lib/Lintian/Check/Languages/Perl/Core/Provides.pm | 83 ++ .../Check/Languages/Perl/Perl4/Prerequisites.pm | 124 +++ lib/Lintian/Check/Languages/Perl/Perl5.pm | 61 ++ lib/Lintian/Check/Languages/Perl/Yapp.pm | 55 + lib/Lintian/Check/Languages/Php.pm | 53 + lib/Lintian/Check/Languages/Php/Composer.pm | 93 ++ lib/Lintian/Check/Languages/Php/Embedded.pm | 92 ++ lib/Lintian/Check/Languages/Php/Pear.pm | 242 +++++ lib/Lintian/Check/Languages/Php/Pear/Embedded.pm | 92 ++ lib/Lintian/Check/Languages/Python.pm | 516 ++++++++++ .../Check/Languages/Python/BogusPrerequisites.pm | 88 ++ .../Check/Languages/Python/DistOverrides.pm | 80 ++ lib/Lintian/Check/Languages/Python/Distutils.pm | 77 ++ lib/Lintian/Check/Languages/Python/Feedparser.pm | 54 + lib/Lintian/Check/Languages/Python/Homepage.pm | 59 ++ lib/Lintian/Check/Languages/Python/Obsolete.pm | 63 ++ lib/Lintian/Check/Languages/Python/Scripts.pm | 54 + lib/Lintian/Check/Languages/R.pm | 74 ++ lib/Lintian/Check/Languages/R/Architecture.pm | 69 ++ lib/Lintian/Check/Languages/R/SiteLibrary.pm | 71 ++ lib/Lintian/Check/Languages/Ruby.pm | 72 ++ lib/Lintian/Check/Languages/Rust.pm | 69 ++ lib/Lintian/Check/Libraries/DebugSymbols.pm | 59 ++ lib/Lintian/Check/Libraries/Embedded.pm | 124 +++ lib/Lintian/Check/Libraries/Shared/Exit.pm | 72 ++ .../Check/Libraries/Shared/FilePermissions.pm | 72 ++ lib/Lintian/Check/Libraries/Shared/Links.pm | 167 +++ lib/Lintian/Check/Libraries/Shared/MultiArch.pm | 79 ++ lib/Lintian/Check/Libraries/Shared/Obsolete.pm | 56 + lib/Lintian/Check/Libraries/Shared/Relocation.pm | 58 ++ lib/Lintian/Check/Libraries/Shared/Soname.pm | 123 +++ .../Check/Libraries/Shared/Soname/Missing.pm | 73 ++ lib/Lintian/Check/Libraries/Shared/Stack.pm | 69 ++ .../Check/Libraries/Shared/Trigger/Ldconfig.pm | 131 +++ lib/Lintian/Check/Libraries/Static.pm | 121 +++ .../Check/Libraries/Static/LinkTimeOptimization.pm | 70 ++ lib/Lintian/Check/Libraries/Static/Name.pm | 61 ++ lib/Lintian/Check/Libraries/Static/NoCode.pm | 95 ++ lib/Lintian/Check/Linda.pm | 47 + lib/Lintian/Check/Lintian.pm | 38 + lib/Lintian/Check/Mailcap.pm | 108 ++ lib/Lintian/Check/MaintainerScripts/Adduser.pm | 96 ++ .../Check/MaintainerScripts/AncientVersion.pm | 180 ++++ lib/Lintian/Check/MaintainerScripts/Diversion.pm | 369 +++++++ .../Check/MaintainerScripts/DpkgStatoverride.pm | 148 +++ lib/Lintian/Check/MaintainerScripts/Empty.pm | 144 +++ lib/Lintian/Check/MaintainerScripts/Generated.pm | 85 ++ lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm | 183 ++++ lib/Lintian/Check/MaintainerScripts/Killall.pm | 131 +++ lib/Lintian/Check/MaintainerScripts/Ldconfig.pm | 60 ++ lib/Lintian/Check/MaintainerScripts/Mknod.pm | 131 +++ lib/Lintian/Check/MaintainerScripts/Systemctl.pm | 76 ++ .../Check/MaintainerScripts/TemporaryFiles.pm | 144 +++ lib/Lintian/Check/Md5sums.pm | 133 +++ lib/Lintian/Check/MenuFormat.pm | 907 ++++++++++++++++ lib/Lintian/Check/Menus.pm | 818 +++++++++++++++ lib/Lintian/Check/Mimeinfo.pm | 61 ++ lib/Lintian/Check/Modprobe.pm | 61 ++ lib/Lintian/Check/Nmu.pm | 193 ++++ lib/Lintian/Check/ObsoleteSites.pm | 96 ++ lib/Lintian/Check/Origtar.pm | 55 + lib/Lintian/Check/Pe.pm | 113 ++ lib/Lintian/Check/Script/Deprecated/Chown.pm | 96 ++ lib/Lintian/Check/Script/Syntax.pm | 224 ++++ lib/Lintian/Check/Scripts.pm | 1070 +++++++++++++++++++ lib/Lintian/Check/Shell/Bash/Completion.pm | 54 + lib/Lintian/Check/Shell/Csh.pm | 89 ++ lib/Lintian/Check/Shell/NonPosix/BashCentric.pm | 348 +++++++ lib/Lintian/Check/Substvars/Libc.pm | 86 ++ lib/Lintian/Check/Substvars/Misc/PreDepends.pm | 64 ++ lib/Lintian/Check/Systemd.pm | 530 ++++++++++ lib/Lintian/Check/Systemd/Native/Prerequisites.pm | 146 +++ lib/Lintian/Check/Systemd/Tmpfiles.pm | 57 + lib/Lintian/Check/Team/PkgJs/Deprecated.pm | 76 ++ lib/Lintian/Check/Team/PkgJs/Testsuite.pm | 73 ++ lib/Lintian/Check/Team/PkgJs/Vcs.pm | 78 ++ lib/Lintian/Check/Team/PkgPerl/Testsuite.pm | 78 ++ lib/Lintian/Check/Team/PkgPerl/Vcs.pm | 77 ++ lib/Lintian/Check/Team/PkgPerl/XsAbi.pm | 95 ++ lib/Lintian/Check/Template/DhMake/Control/Vcs.pm | 77 ++ lib/Lintian/Check/Testsuite.pm | 352 +++++++ lib/Lintian/Check/Triggers.pm | 145 +++ lib/Lintian/Check/Udev.pm | 172 ++++ lib/Lintian/Check/Unpack.pm | 67 ++ lib/Lintian/Check/UpstreamSignature.pm | 126 +++ lib/Lintian/Check/Usrmerge.pm | 66 ++ lib/Lintian/Check/Vim.pm | 53 + lib/Lintian/Check/Vim/Addons.pm | 48 + 345 files changed, 46943 insertions(+) create mode 100644 lib/Lintian/Check/Apache2.pm create mode 100644 lib/Lintian/Check/ApplicationNotLibrary.pm create mode 100644 lib/Lintian/Check/AppstreamMetadata.pm create mode 100644 lib/Lintian/Check/Apt.pm create mode 100644 lib/Lintian/Check/Archive/File/Name/Length.pm create mode 100644 lib/Lintian/Check/Archive/Liberty/Mismatch.pm create mode 100644 lib/Lintian/Check/Archive/NonFree/Autobuild.pm create mode 100644 lib/Lintian/Check/Binaries.pm create mode 100644 lib/Lintian/Check/Binaries/Architecture.pm create mode 100644 lib/Lintian/Check/Binaries/Architecture/Other.pm create mode 100644 lib/Lintian/Check/Binaries/Corrupted.pm create mode 100644 lib/Lintian/Check/Binaries/DebugSymbols.pm create mode 100644 lib/Lintian/Check/Binaries/DebugSymbols/Detached.pm create mode 100644 lib/Lintian/Check/Binaries/Hardening.pm create mode 100644 lib/Lintian/Check/Binaries/LargeFileSupport.pm create mode 100644 lib/Lintian/Check/Binaries/Location.pm create mode 100644 lib/Lintian/Check/Binaries/Obsolete/Crypt.pm create mode 100644 lib/Lintian/Check/Binaries/Prerequisites.pm create mode 100644 lib/Lintian/Check/Binaries/Prerequisites/Numpy.pm create mode 100644 lib/Lintian/Check/Binaries/Prerequisites/Perl.pm create mode 100644 lib/Lintian/Check/Binaries/Prerequisites/Php.pm create mode 100644 lib/Lintian/Check/Binaries/Profiling.pm create mode 100644 lib/Lintian/Check/Binaries/Rpath.pm create mode 100644 lib/Lintian/Check/Binaries/Spelling.pm create mode 100644 lib/Lintian/Check/Binaries/Static.pm create mode 100644 lib/Lintian/Check/BuildSystems/Automake.pm create mode 100644 lib/Lintian/Check/BuildSystems/Autotools.pm create mode 100644 lib/Lintian/Check/BuildSystems/Autotools/Libtool.pm create mode 100644 lib/Lintian/Check/BuildSystems/Cmake.pm create mode 100644 lib/Lintian/Check/BuildSystems/Debhelper/MaintainerScript/Token.pm create mode 100644 lib/Lintian/Check/BuildSystems/Libtool/LaFile.pm create mode 100644 lib/Lintian/Check/BuildSystems/Waf.pm create mode 100644 lib/Lintian/Check/ChangesFile.pm create mode 100644 lib/Lintian/Check/Conffiles.pm create mode 100644 lib/Lintian/Check/ContinuousIntegration/Salsa.pm create mode 100644 lib/Lintian/Check/ControlFiles.pm create mode 100644 lib/Lintian/Check/Cron.pm create mode 100644 lib/Lintian/Check/Cruft.pm create mode 100644 lib/Lintian/Check/DebFormat.pm create mode 100644 lib/Lintian/Check/Debhelper.pm create mode 100644 lib/Lintian/Check/Debhelper/Temporary.pm create mode 100644 lib/Lintian/Check/Debian/Changelog.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Adopted.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Architecture/Multiline.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/BuildProfiles.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/BuiltUsing.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Description/Duplicate.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/DoubledUp.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Empty.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Misplaced.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Redundant.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Relation.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/RulesRequiresRoot.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Section.pm create mode 100644 lib/Lintian/Check/Debian/Control/Field/Spacing.pm create mode 100644 lib/Lintian/Check/Debian/Control/Link.pm create mode 100644 lib/Lintian/Check/Debian/Control/Prerequisite/Circular.pm create mode 100644 lib/Lintian/Check/Debian/Control/Prerequisite/Development.pm create mode 100644 lib/Lintian/Check/Debian/Control/Prerequisite/Redundant.pm create mode 100644 lib/Lintian/Check/Debian/Copyright.pm create mode 100644 lib/Lintian/Check/Debian/Copyright/ApacheNotice.pm create mode 100644 lib/Lintian/Check/Debian/Copyright/Dep5.pm create mode 100644 lib/Lintian/Check/Debian/Copyright/Dep5/Components.pm create mode 100644 lib/Lintian/Check/Debian/Debconf.pm create mode 100644 lib/Lintian/Check/Debian/DesktopEntries.pm create mode 100644 lib/Lintian/Check/Debian/Filenames.pm create mode 100644 lib/Lintian/Check/Debian/Files.pm create mode 100644 lib/Lintian/Check/Debian/LineSeparators.pm create mode 100644 lib/Lintian/Check/Debian/LintianOverrides.pm create mode 100644 lib/Lintian/Check/Debian/LintianOverrides/Comments.pm create mode 100644 lib/Lintian/Check/Debian/LintianOverrides/Duplicate.pm create mode 100644 lib/Lintian/Check/Debian/LintianOverrides/Malformed.pm create mode 100644 lib/Lintian/Check/Debian/LintianOverrides/Mystery.pm create mode 100644 lib/Lintian/Check/Debian/LintianOverrides/Restricted.pm create mode 100644 lib/Lintian/Check/Debian/Maintscript.pm create mode 100644 lib/Lintian/Check/Debian/ManualPages.pm create mode 100644 lib/Lintian/Check/Debian/NotInstalled.pm create mode 100644 lib/Lintian/Check/Debian/Patches.pm create mode 100644 lib/Lintian/Check/Debian/Patches/Count.pm create mode 100644 lib/Lintian/Check/Debian/Patches/Dep3.pm create mode 100644 lib/Lintian/Check/Debian/Patches/Dpatch.pm create mode 100644 lib/Lintian/Check/Debian/Patches/Quilt.pm create mode 100644 lib/Lintian/Check/Debian/PoDebconf.pm create mode 100644 lib/Lintian/Check/Debian/Readme.pm create mode 100644 lib/Lintian/Check/Debian/Rules.pm create mode 100644 lib/Lintian/Check/Debian/Rules/DhSequencer.pm create mode 100644 lib/Lintian/Check/Debian/Shlibs.pm create mode 100644 lib/Lintian/Check/Debian/Source/IncludeBinaries.pm create mode 100644 lib/Lintian/Check/Debian/SourceDir.pm create mode 100644 lib/Lintian/Check/Debian/Substvars.pm create mode 100644 lib/Lintian/Check/Debian/Symbols.pm create mode 100644 lib/Lintian/Check/Debian/TrailingWhitespace.pm create mode 100644 lib/Lintian/Check/Debian/Upstream/Metadata.pm create mode 100644 lib/Lintian/Check/Debian/Upstream/SigningKey.pm create mode 100644 lib/Lintian/Check/Debian/Variables.pm create mode 100644 lib/Lintian/Check/Debian/VersionSubstvars.pm create mode 100644 lib/Lintian/Check/Debian/Watch.pm create mode 100644 lib/Lintian/Check/Debian/Watch/Standard.pm create mode 100644 lib/Lintian/Check/Debug/Automatic.pm create mode 100644 lib/Lintian/Check/Debug/Obsolete.pm create mode 100644 lib/Lintian/Check/Desktop/Dbus.pm create mode 100644 lib/Lintian/Check/Desktop/Gnome.pm create mode 100644 lib/Lintian/Check/Desktop/Gnome/Gir.pm create mode 100644 lib/Lintian/Check/Desktop/Gnome/Gir/Substvars.pm create mode 100644 lib/Lintian/Check/Desktop/Icons.pm create mode 100644 lib/Lintian/Check/Desktop/X11.pm create mode 100644 lib/Lintian/Check/Desktop/X11/Font/Update.pm create mode 100644 lib/Lintian/Check/DhMake.pm create mode 100644 lib/Lintian/Check/DhMake/Template.pm create mode 100644 lib/Lintian/Check/Documentation.pm create mode 100644 lib/Lintian/Check/Documentation/Devhelp.pm create mode 100644 lib/Lintian/Check/Documentation/Devhelp/Standard.pm create mode 100644 lib/Lintian/Check/Documentation/Doxygen.pm create mode 100644 lib/Lintian/Check/Documentation/Examples.pm create mode 100644 lib/Lintian/Check/Documentation/Manual.pm create mode 100644 lib/Lintian/Check/Documentation/Texinfo.pm create mode 100644 lib/Lintian/Check/Emacs.pm create mode 100644 lib/Lintian/Check/Emacs/Elpa.pm create mode 100644 lib/Lintian/Check/Examples.pm create mode 100644 lib/Lintian/Check/Executable.pm create mode 100644 lib/Lintian/Check/Fields/Architecture.pm create mode 100644 lib/Lintian/Check/Fields/Bugs.pm create mode 100644 lib/Lintian/Check/Fields/BuiltUsing.pm create mode 100644 lib/Lintian/Check/Fields/ChangedBy.pm create mode 100644 lib/Lintian/Check/Fields/Checksums.pm create mode 100644 lib/Lintian/Check/Fields/Deb822.pm create mode 100644 lib/Lintian/Check/Fields/Derivatives.pm create mode 100644 lib/Lintian/Check/Fields/Description.pm create mode 100644 lib/Lintian/Check/Fields/Distribution.pm create mode 100644 lib/Lintian/Check/Fields/DmUploadAllowed.pm create mode 100644 lib/Lintian/Check/Fields/Empty.pm create mode 100644 lib/Lintian/Check/Fields/Essential.pm create mode 100644 lib/Lintian/Check/Fields/Format.pm create mode 100644 lib/Lintian/Check/Fields/Homepage.pm create mode 100644 lib/Lintian/Check/Fields/InstallerMenuItem.pm create mode 100644 lib/Lintian/Check/Fields/Length.pm create mode 100644 lib/Lintian/Check/Fields/MailAddress.pm create mode 100644 lib/Lintian/Check/Fields/Maintainer.pm create mode 100644 lib/Lintian/Check/Fields/Maintainer/Team.pm create mode 100644 lib/Lintian/Check/Fields/MultiArch.pm create mode 100644 lib/Lintian/Check/Fields/MultiLine.pm create mode 100644 lib/Lintian/Check/Fields/Origin.pm create mode 100644 lib/Lintian/Check/Fields/Package.pm create mode 100644 lib/Lintian/Check/Fields/PackageRelations.pm create mode 100644 lib/Lintian/Check/Fields/PackageType.pm create mode 100644 lib/Lintian/Check/Fields/Priority.pm create mode 100644 lib/Lintian/Check/Fields/Recommended.pm create mode 100644 lib/Lintian/Check/Fields/Required.pm create mode 100644 lib/Lintian/Check/Fields/Section.pm create mode 100644 lib/Lintian/Check/Fields/Source.pm create mode 100644 lib/Lintian/Check/Fields/StandardsVersion.pm create mode 100644 lib/Lintian/Check/Fields/Style.pm create mode 100644 lib/Lintian/Check/Fields/Subarchitecture.pm create mode 100644 lib/Lintian/Check/Fields/TerminalControl.pm create mode 100644 lib/Lintian/Check/Fields/Trimmed.pm create mode 100644 lib/Lintian/Check/Fields/Unknown.pm create mode 100644 lib/Lintian/Check/Fields/Uploaders.pm create mode 100644 lib/Lintian/Check/Fields/Urgency.pm create mode 100644 lib/Lintian/Check/Fields/Vcs.pm create mode 100644 lib/Lintian/Check/Fields/Version.pm create mode 100644 lib/Lintian/Check/Fields/Version/Derivative.pm create mode 100644 lib/Lintian/Check/Fields/Version/Repack/Count.pm create mode 100644 lib/Lintian/Check/Fields/Version/Repack/Native.pm create mode 100644 lib/Lintian/Check/Fields/Version/Repack/Period.pm create mode 100644 lib/Lintian/Check/Fields/Version/Repack/Tilde.pm create mode 100644 lib/Lintian/Check/Fields/Version/Repack/Typo.pm create mode 100644 lib/Lintian/Check/Files/Architecture.pm create mode 100644 lib/Lintian/Check/Files/Artifact.pm create mode 100644 lib/Lintian/Check/Files/Banned.pm create mode 100644 lib/Lintian/Check/Files/Banned/CompiledHelp.pm create mode 100644 lib/Lintian/Check/Files/Banned/Lenna.pm create mode 100644 lib/Lintian/Check/Files/Bugs.pm create mode 100644 lib/Lintian/Check/Files/BuildPath.pm create mode 100644 lib/Lintian/Check/Files/Compressed.pm create mode 100644 lib/Lintian/Check/Files/Compressed/Bz2.pm create mode 100644 lib/Lintian/Check/Files/Compressed/Gz.pm create mode 100644 lib/Lintian/Check/Files/Compressed/Lz.pm create mode 100644 lib/Lintian/Check/Files/Compressed/Lzma.pm create mode 100644 lib/Lintian/Check/Files/Compressed/Lzo.pm create mode 100644 lib/Lintian/Check/Files/Compressed/Xz.pm create mode 100644 lib/Lintian/Check/Files/Compressed/Zip.pm create mode 100644 lib/Lintian/Check/Files/ConfigScripts.pm create mode 100644 lib/Lintian/Check/Files/Contents.pm create mode 100644 lib/Lintian/Check/Files/Contents/LineLength.pm create mode 100644 lib/Lintian/Check/Files/Date.pm create mode 100644 lib/Lintian/Check/Files/Debug.pm create mode 100644 lib/Lintian/Check/Files/DebugPackages.pm create mode 100644 lib/Lintian/Check/Files/Desktop.pm create mode 100644 lib/Lintian/Check/Files/Duplicates.pm create mode 100644 lib/Lintian/Check/Files/EmptyDirectories.pm create mode 100644 lib/Lintian/Check/Files/EmptyPackage.pm create mode 100644 lib/Lintian/Check/Files/Encoding.pm create mode 100644 lib/Lintian/Check/Files/Generated.pm create mode 100644 lib/Lintian/Check/Files/HardLinks.pm create mode 100644 lib/Lintian/Check/Files/Hierarchy/Links.pm create mode 100644 lib/Lintian/Check/Files/Hierarchy/MergedUsr.pm create mode 100644 lib/Lintian/Check/Files/Hierarchy/PathSegments.pm create mode 100644 lib/Lintian/Check/Files/Hierarchy/Standard.pm create mode 100644 lib/Lintian/Check/Files/IeeeData.pm create mode 100644 lib/Lintian/Check/Files/Includes.pm create mode 100644 lib/Lintian/Check/Files/Init.pm create mode 100644 lib/Lintian/Check/Files/LdSo.pm create mode 100644 lib/Lintian/Check/Files/Licenses.pm create mode 100644 lib/Lintian/Check/Files/Locales.pm create mode 100644 lib/Lintian/Check/Files/Missing.pm create mode 100644 lib/Lintian/Check/Files/MultiArch.pm create mode 100644 lib/Lintian/Check/Files/Names.pm create mode 100644 lib/Lintian/Check/Files/NonFree.pm create mode 100644 lib/Lintian/Check/Files/ObsoletePaths.pm create mode 100644 lib/Lintian/Check/Files/Openpgp.pm create mode 100644 lib/Lintian/Check/Files/Ownership.pm create mode 100644 lib/Lintian/Check/Files/P11Kit.pm create mode 100644 lib/Lintian/Check/Files/Pam.pm create mode 100644 lib/Lintian/Check/Files/Permissions.pm create mode 100644 lib/Lintian/Check/Files/Permissions/UsrLib.pm create mode 100644 lib/Lintian/Check/Files/Pkgconfig.pm create mode 100644 lib/Lintian/Check/Files/PrivacyBreach.pm create mode 100644 lib/Lintian/Check/Files/Scripts.pm create mode 100644 lib/Lintian/Check/Files/Sgml.pm create mode 100644 lib/Lintian/Check/Files/SourceMissing.pm create mode 100644 lib/Lintian/Check/Files/Special.pm create mode 100644 lib/Lintian/Check/Files/SymbolicLinks.pm create mode 100644 lib/Lintian/Check/Files/SymbolicLinks/Broken.pm create mode 100644 lib/Lintian/Check/Files/Unicode/Trojan.pm create mode 100644 lib/Lintian/Check/Files/Unwanted.pm create mode 100644 lib/Lintian/Check/Files/UsrMerge.pm create mode 100644 lib/Lintian/Check/Files/Vcs.pm create mode 100644 lib/Lintian/Check/Fonts.pm create mode 100644 lib/Lintian/Check/Fonts/Opentype.pm create mode 100644 lib/Lintian/Check/Fonts/Postscript/Type1.pm create mode 100644 lib/Lintian/Check/Fonts/Truetype.pm create mode 100644 lib/Lintian/Check/ForeignOperatingSystems.pm create mode 100644 lib/Lintian/Check/Games.pm create mode 100644 lib/Lintian/Check/GroupChecks.pm create mode 100644 lib/Lintian/Check/HugeUsrShare.pm create mode 100644 lib/Lintian/Check/Images.pm create mode 100644 lib/Lintian/Check/Images/Filenames.pm create mode 100644 lib/Lintian/Check/Images/Thumbnails.pm create mode 100644 lib/Lintian/Check/Includes/ConfigH.pm create mode 100644 lib/Lintian/Check/InitD.pm create mode 100644 lib/Lintian/Check/InitD/MaintainerScript.pm create mode 100644 lib/Lintian/Check/Languages/Fortran/Gfortran.pm create mode 100644 lib/Lintian/Check/Languages/Golang/BuiltUsing.pm create mode 100644 lib/Lintian/Check/Languages/Golang/ImportPath.pm create mode 100644 lib/Lintian/Check/Languages/Java.pm create mode 100644 lib/Lintian/Check/Languages/Java/Bytecode.pm create mode 100644 lib/Lintian/Check/Languages/Javascript/Embedded.pm create mode 100644 lib/Lintian/Check/Languages/Javascript/Nodejs.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/ByteCode/Compiled.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/ByteCode/Interface.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/ByteCode/Library.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Package.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/ByteCode/Misplaced/Path.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/ByteCode/Plugin.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/CustomExecutable.pm create mode 100644 lib/Lintian/Check/Languages/Ocaml/Meta.pm create mode 100644 lib/Lintian/Check/Languages/Perl.pm create mode 100644 lib/Lintian/Check/Languages/Perl/Core/Provides.pm create mode 100644 lib/Lintian/Check/Languages/Perl/Perl4/Prerequisites.pm create mode 100644 lib/Lintian/Check/Languages/Perl/Perl5.pm create mode 100644 lib/Lintian/Check/Languages/Perl/Yapp.pm create mode 100644 lib/Lintian/Check/Languages/Php.pm create mode 100644 lib/Lintian/Check/Languages/Php/Composer.pm create mode 100644 lib/Lintian/Check/Languages/Php/Embedded.pm create mode 100644 lib/Lintian/Check/Languages/Php/Pear.pm create mode 100644 lib/Lintian/Check/Languages/Php/Pear/Embedded.pm create mode 100644 lib/Lintian/Check/Languages/Python.pm create mode 100644 lib/Lintian/Check/Languages/Python/BogusPrerequisites.pm create mode 100644 lib/Lintian/Check/Languages/Python/DistOverrides.pm create mode 100644 lib/Lintian/Check/Languages/Python/Distutils.pm create mode 100644 lib/Lintian/Check/Languages/Python/Feedparser.pm create mode 100644 lib/Lintian/Check/Languages/Python/Homepage.pm create mode 100644 lib/Lintian/Check/Languages/Python/Obsolete.pm create mode 100644 lib/Lintian/Check/Languages/Python/Scripts.pm create mode 100644 lib/Lintian/Check/Languages/R.pm create mode 100644 lib/Lintian/Check/Languages/R/Architecture.pm create mode 100644 lib/Lintian/Check/Languages/R/SiteLibrary.pm create mode 100644 lib/Lintian/Check/Languages/Ruby.pm create mode 100644 lib/Lintian/Check/Languages/Rust.pm create mode 100644 lib/Lintian/Check/Libraries/DebugSymbols.pm create mode 100644 lib/Lintian/Check/Libraries/Embedded.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Exit.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/FilePermissions.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Links.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/MultiArch.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Obsolete.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Relocation.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Soname.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Soname/Missing.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Stack.pm create mode 100644 lib/Lintian/Check/Libraries/Shared/Trigger/Ldconfig.pm create mode 100644 lib/Lintian/Check/Libraries/Static.pm create mode 100644 lib/Lintian/Check/Libraries/Static/LinkTimeOptimization.pm create mode 100644 lib/Lintian/Check/Libraries/Static/Name.pm create mode 100644 lib/Lintian/Check/Libraries/Static/NoCode.pm create mode 100644 lib/Lintian/Check/Linda.pm create mode 100644 lib/Lintian/Check/Lintian.pm create mode 100644 lib/Lintian/Check/Mailcap.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Adduser.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/AncientVersion.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Diversion.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/DpkgStatoverride.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Empty.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Generated.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Helper/Dpkg.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Killall.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Ldconfig.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Mknod.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/Systemctl.pm create mode 100644 lib/Lintian/Check/MaintainerScripts/TemporaryFiles.pm create mode 100644 lib/Lintian/Check/Md5sums.pm create mode 100644 lib/Lintian/Check/MenuFormat.pm create mode 100644 lib/Lintian/Check/Menus.pm create mode 100644 lib/Lintian/Check/Mimeinfo.pm create mode 100644 lib/Lintian/Check/Modprobe.pm create mode 100644 lib/Lintian/Check/Nmu.pm create mode 100644 lib/Lintian/Check/ObsoleteSites.pm create mode 100644 lib/Lintian/Check/Origtar.pm create mode 100644 lib/Lintian/Check/Pe.pm create mode 100644 lib/Lintian/Check/Script/Deprecated/Chown.pm create mode 100644 lib/Lintian/Check/Script/Syntax.pm create mode 100644 lib/Lintian/Check/Scripts.pm create mode 100644 lib/Lintian/Check/Shell/Bash/Completion.pm create mode 100644 lib/Lintian/Check/Shell/Csh.pm create mode 100644 lib/Lintian/Check/Shell/NonPosix/BashCentric.pm create mode 100644 lib/Lintian/Check/Substvars/Libc.pm create mode 100644 lib/Lintian/Check/Substvars/Misc/PreDepends.pm create mode 100644 lib/Lintian/Check/Systemd.pm create mode 100644 lib/Lintian/Check/Systemd/Native/Prerequisites.pm create mode 100644 lib/Lintian/Check/Systemd/Tmpfiles.pm create mode 100644 lib/Lintian/Check/Team/PkgJs/Deprecated.pm create mode 100644 lib/Lintian/Check/Team/PkgJs/Testsuite.pm create mode 100644 lib/Lintian/Check/Team/PkgJs/Vcs.pm create mode 100644 lib/Lintian/Check/Team/PkgPerl/Testsuite.pm create mode 100644 lib/Lintian/Check/Team/PkgPerl/Vcs.pm create mode 100644 lib/Lintian/Check/Team/PkgPerl/XsAbi.pm create mode 100644 lib/Lintian/Check/Template/DhMake/Control/Vcs.pm create mode 100644 lib/Lintian/Check/Testsuite.pm create mode 100644 lib/Lintian/Check/Triggers.pm create mode 100644 lib/Lintian/Check/Udev.pm create mode 100644 lib/Lintian/Check/Unpack.pm create mode 100644 lib/Lintian/Check/UpstreamSignature.pm create mode 100644 lib/Lintian/Check/Usrmerge.pm create mode 100644 lib/Lintian/Check/Vim.pm create mode 100644 lib/Lintian/Check/Vim/Addons.pm (limited to 'lib/Lintian/Check') 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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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- 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{}xsm, qr{}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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 ``). +# +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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+/.*(?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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# +# 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 +# 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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 +# 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, ' $ITEM_NOT_FOUND){ + + $blockscript = substr($blockscript,$indexscript); + + # sourced script ok + if ($blockscript =~ m{\A]*?src="[^"]+?"[^>]*?>}sm) + { + + $blockscript = substr($blockscript,$+[0]); + next; + } + + # extract script + if ($blockscript =~ m{]*?>(.*?)}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{}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{ }{ }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; # end XML comment + + $text =~ s{]*?>}{ }gxms; # a link + $text =~ s{}{ }gxms; # (X)?HTML line + # breaks + $text =~ s{]*?>}{ }gxms; # DocBook citation title + $text =~ s{]*?>}{ }gxms; # html style + $text =~ s{]*?>}{ }gxms; # bold + $text =~ s{]*?>}{ }gxms; # italic + $text =~ s{]*?>}{ }gxms; # italic + $text =~ s{]*?>}{ }gxms; # xml link + $text =~ s{]*?>}{ }gxms; # html paragraph + $text =~ s{]*?>}{ }gxms; # xml quote + $text =~ s{]*?>}{ }gxms; # span tag + $text =~ s{]*?>}{ }gxms; # ulink DocBook + $text =~ s{]*?>}{ }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 +# +# This program is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 2 of the License, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU 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 . + +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 +# 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", [.]copyright, [.]changelog + # and [.]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 =~ /((?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 +# 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 +# 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 +# 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 +# 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 +# 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+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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 + # <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 +# 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 .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{} + || $contents =~ // + || $contents =~ // + || $contents =~ // + || $contents =~ /Upstream Author\(s\)/ + || $contents =~ // + || $contents =~ // + || $contents + =~ // + || $contents + =~ // + || $contents =~ // + || $contents =~ //; + + # 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 =~ //; + + $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; +} # + +# ----------------------------------- + +# 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; +} # + +# ----------------------------------- + +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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 +# 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', + '', + '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 +# Copyright (C) 2005 Rene van Bevern +# Copyright (C) 2019-2020 Chris Lamb +# 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" (#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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 +# 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_.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 +# 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 +# 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 +# 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 +# Copyright (C) 2005 Rene van Bevern +# Copyright (C) 2019-2020 Chris Lamb +# 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 +# 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/()/); + 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/(?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 +# 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 +# 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 or whatever. + + my @rules; + # a small rubbish state machine: we want to match a containing + # any or rule that is about sending + my $policy = $EMPTY; + while ($xml =~ m{(]*>)|()|(<(?: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 + # + $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['"].*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{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 +# 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 +# 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 +# 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/(?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 +# 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 +# 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. + # + $self->pointed_hint('source-contains-prebuilt-doxygen-documentation', + $item->pointer) + if $lowercase =~ m{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/^://; + + $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 +# 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 +# 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 +# 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/(?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//) { + $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: 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 =~ //) { + $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 +# 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 +# +# 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 +# +# 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 +# +# 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 +# +# 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 | 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] " 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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 +# +# 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 +# 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 +# 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 +# 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 +# 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 +# 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{(? ( + 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 +# 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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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(?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(?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 +# Copyright (C) 2019 Adam D. Barratt +# Copyright (C) 2021 Felix Lechner +# +# Based in part on a shell script that was: +# Copyright (C) 2010 Raphael Geissert +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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 +# 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 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, you can find it on the World Wide +# Web at https://www.gnu.org/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(